% ======================================================================
% T h e T e X - R e d u c e - I n t e r f a c e
% ======================================================================
% (C) 1987/1988 by Rechenzentrum der Universitaet zu Koeln
% (University of Cologne Computer Center)
% Abt. Anwendungssoftware
% (Application Software Department)
% ATTN: Werner Antweiler
% Robert-Koch-Str. 10
% 5000 Koeln 41
% Federal Republic of Germany
% E-Mail: reduce@rrz.Uni-Koeln.DE
% All rights reserved. Permission to copy without fee all or part of
% this software product is hereby granted provided that the copies are
% not made or distributed for direct commercial advantage, this copy-
% right notice and its date appear, and notice is given that copying is
% by permission of the authors. To copy otherwise requires a fee and/or
% specific permission. This software product has been developed by
% WERNER ANTWEILER at the University of Cologne Computer Center, West
% Germany. The TeX-Reduce-Interface has been totally written in REDUCE-
% LISP.
% ======================================================================
% Last Update: 19-Mar-93 Version 0.60
% ======================================================================
%
% Section Survey
% ----------------------------------------------------------------------
% Section Contents Page
% ----------------------------------------------------------------------
% 0 Main Procedure (and Interfacing) 2
% 1 Creating a TeX item list 5
% 1.1 Operator Administration Routines 5
% 1.2 Prefix to Infix Conversion 6
% 1.3 Making a TeX item 9
% 2 Inserting Glue Items 16
% 3 Line Breaking 18
% 3.1 Resolving Fraction Expressions 20
% 3.2 Creating a Break List 21
% 3.3 Major Line Breaking Routine 23
% 4 TeX-Output Routines 28
% 5 User Interface 30
% ----------------------------------------------------------------------
% Note: page breaks (form feeds) are indicated by "%ff" lines
%ff
% ----------------------------------------------------------------------
% Section 0: Global Variables, Main Procedure and Interfacing
% ----------------------------------------------------------------------
% IMPORTANT NOTICE FOR REDUCE 3.2 USERS:
% This code was written to run under REDUCE 3.3. Users of REDUCE 3.2
% therefore have to change two lines of this code before compiling it:
% 1) the line `switch ...;` must be deleted
% 2) the construct `FOR EACH ... IN ... JOIN ...` must be changed
% to `FOR EACH ... IN ... CONC ...` because only the latter is
% accepted by REDUCE 3.2.
% Furthermore, the TRI supports features of REDUCE that are new in ver-
% sion 3.3. You cannot take advantage of them under version 3.2. In parti-
% cular, some of the examples in the accompanying test file may fail.
module tri;
global '(
% -----------------+---------------------------------------------------+
% GLOBAL VARIABLES | EXPLANATION |
% -----------------+---------------------------------------------------+
!*TeX % flag to be switched ON and OFF (TeX Output Mode)
!*TeXBreak % flag to be switched ON and OFF (Break Facility)
!*TeXIndent % flag to be switched ON and OFF (Indentation Mode)
TeXstack!* % stack to save expressions for an unfilled line
hsize!* % total page width in scaled points (sp)
% note: 65536sp = 1pt = 1/72.27 inch
hss!* % total line stretchability/shrinkability (in sp)
hww!* % optimum page fit width (= 3/4 hsize) (in sp)
tolerance!* % value within break points are considered to be
% feasible (range: 0..10000)
metricu!* % ??
indxl!* % ??
% -----------------+---------------------------------------------------+
);
% declare switches:
switch TeX,TeXBreak,TeXIndent;
% declare switch dependencies:
put('TeXIndent,'simpfg,'((T (progn (setq !*TeX T)
(setq !*TeXBreak T))) ));
put('TeXBreak,'simpfg,'((T (setq !*TeX T)) ));
put('TeX,'simpfg,'((NIL (progn (setq !*TeXBreak NIL)
(setq !*TeXIndent NIL))) ));
symbolic procedure tri!-error(strlst,errclass);
<< for each x in strlst do prin2 x; terpri();
if errclass='fatal then
rederr "Aborting."
>>;
%ff
%%symbolic procedure varpri(u,v,w); % REDUCE 3.3 version
%%% parameters: u ..... expression to be printed
%%% v ..... a list of expressions assigned to <u>
%%% w ..... a flag (true if <u> is last in current set)
%%begin
%% scalar x;
%% if null u then u:=0; % allow for unset array elements
%% if !*NERO and (u=0) then return;
%% v:=setvars v;
%% if !*TeX then return if (x := getrtype u) and get(x,'TeXprifn)
%% then apply3(get(x,'TeXprifn),u,v,w)
%% else TeXvarpri(u,v,w);
%% if (x:=getrtype u) and flagp(x,'SPRIFN)
%% then return if null v then apply1(get(get(x,'TAG),'PRIFN),u)
%% else maprin list('SETQ,car v,u);
%% if w memq '(FIRST ONLY) then terpri!*(T);
%% if !*FORT then return fvarpri(u,v,w);
%% if v then u:='SETQ . ACONC(V,U);
%% maprin u;
%% if null w or (w eq 'FIRST) then return nil
%% else if not !*NAT then prin2!*("$");
%% terpri!*(not !*NAT); return(nil)
%%end;
symbolic procedure varpri(u,v,w); % REDUCE 3.4 version
begin scalar x;
%U is expression being printed
%V is the original form that was evaluated.
%W is an id that indicates if U is the first, only or last element
% in the current set (or NIL otherwise).
testing!-width!* := overflowed!* := nil;
if null u then u := 0;
if !*nero and u=0 then return nil;
v := setvars v;
if !*TeX then return if (x := getrtype u) and get(x,'TeXprifn)
then apply3(get(x,'TeXprifn),u,v,w)
else TeXvarpri(u,v,w);
if (x := getrtype u) and flagp(x,'sprifn)
then return if null v then apply1(get(get(x,'tag),'prifn),u)
else maprin list('setq,car v,u);
if w memq '(first only) then terpri!* t;
if !*fort then return fvarpri(u,v,w);
if v then u := 'setq . aconc(v,u);
maprin u;
if null w or w eq 'first then return nil
else if not !*nat then prin2!* "$";
terpri!*(not !*nat);
return nil
end;
symbolic procedure TeXvarpri(u,v,w); % same parameters as above
<< if w memq '(FIRST ONLY) then TeXStack!*:=nil; u:=makeprefix u;
if v then for each x in reverse v do u:=list('SETQ,x,u);
TeXStack!* := nconc(TeXStack!*,mktag(u,0,nil));
if (w=T) or (w='ONLY) or (w='LAST) then
<< if !*TeXBreak then
<< TeXStack!* := insertglue(TeXStack!*);
TeXStack!* := trybreak(TeXStack!*,breaklist(TeXStack!*))
>>;
TeXout(TeXStack!*,!*TeXBreak); TeXStack!*:=nil
>>;
if (null w) or (w eq 'FIRST) then
TeXStack!* := nconc(TeXStack!*,list '!\!q!u!a!d! );
nil
>>;
%ff
% The following procedure interfaces to E. Schruefer's EXCALC package.
% Courtesy: E. Schruefer.
put('form!-with!-free!-indices,'TeXprifn,'TeXindxpri);
symbolic procedure TeXindxpri(u,v,w);
begin scalar metricu,il,dnlist,uplist,r,x,y,z;
if v then go to a;
metricu := metricu!*;
metricu!* := nil;
il := allind !*t2f lt numr simp0 u;
for each j in il do
if atom revalind j
then uplist := j . uplist
else dnlist := cadr j . dnlist;
for each j in intersection(uplist,dnlist) do
il := delete(j,delete(revalind
lowerind j,il));
metricu!* := metricu;
y := flatindxl il;
r := simp!* u;
for each j in mkaindxc y do
<<x := pair(y,j);
z := exc!-mk!*sq2 multsq(subfindices(numr r,x),1 ./ denr r);
if null(!*nero and (z = 0))
then TeXvarpri(z,list subla(x,'ns . il),'only)>>;
return u;
a: v := car v;
y := flatindxl allindk v;
for each j in if flagp(car v,'antisymmetric) and
coposp cdr v then comb(indxl!*,length y)
else mkaindxc y do
<<x := pair(y,j);
z := aeval subla(x,v);
if null(!*nero and (z = 0))
then TeXvarpri(z,list subla(x,v),'only)>>;
return u
end;
%ff
% ----------------------------------------------------------------------
% Section 1: Creating a TeX item list
% ----------------------------------------------------------------------
%
% Linearization is performed by expanding REDUCE prefix expressions into
% a so called "TeX item list". Any TeX item is a readable TeX primitive
% or macro (i.e. a LISP atom), with properties 'CLASS, 'TEXTAG, 'TEXNAME
% and eventually 'TEXPREC, 'TEXPATT and 'TEXUBY bound to them, depending
% on what kind of TeX item it actually is. (See Section 1.3 for further
% information.)
% A REDUCE expression is expanded using the two functions "mktag"
% and "makefunc". Function "mktag" identifies the operator and is able
% to put some brackets around the expression if necessary. "makefunc" is
% a pattern oriented 'unification' function, which matches the arguments
% of a REDUCE expression in order of appearance with so called 'unifica-
% tion tags', as explained below. "mktag" and "makefunc" are highly
% recursive functions.
% The patterns mentioned above are lists (consisting of 'tags') asso-
% ciated with each REDUCE operator. A tag is defined as either an atom
% declared as a TeX item or one of the following 'unification tags':
% (F) ............ insert operator
% (X) ............ insert non-associative argument
% (Y) ............ insert (left/right-) associative argument
% (Z) ............ insert superscript/subscript argument
% (R) ............ use tail recursion to unify remaining arguments
% (associativity depends on previous (X) or (Y) )
% (L) ............ insert a list of arguments (eat up all arguments)
% (M) ............ insert a matrix (and eat up all arguments)
% (APPLY <fun>) ... apply function <fun> to remaining argument list
% ----------------------------------------------------------------------
symbolic procedure makeprefix(ex); % change to standard list notation
(lambda aexpr; % not tricky but time consuming
(if atom aexpr then aexpr
else if car(aexpr)='MAT
then 'MAT . (for each column in cdr aexpr collect
for each row in column collect prepsq!* simp row)
else if car(aexpr)='LIST
then 'LIST . (for each item in cdr aexpr collect makeprefix item)
else if car(aexpr)='EQUAL
then 'EQUAL .(for each item in cdr aexpr collect makeprefix item)
else prepsq!* simp aexpr))
aeval ex;
% ----------------------------------------------------------------------
% Section 1.1: Operator Administration Routines
% ----------------------------------------------------------------------
symbolic procedure makeop(op,prec,patt,uby);
<< put(op,'TEXPREC,prec); put(op,'TEXPATT,patt);
put(op,'TEXUBY,if uby then (car uby).(cadr uby) else nil.nil)
>>;
symbolic procedure makeops(l);
for each w in l do makeop(car w,cadr w,caddr w,cadddr w);
%ff
makeops('(
%-----------+----------+---------------------+-------------------------+
% Name |Precedence|Expansion List |Unary/Binary Interchange |
%-----------+----------+---------------------+-------------------------+
(SETQ 1 ((X) (F) !\![ (X) !\!]) NIL)
(EQUAL 50 ((X) (F) !\![ (X) !\!]) NIL)
(WEDGE 150 ((Y) (F) (R)) NIL) % EXCALC
(PLUS 100 ((Y) (F) (R)) (MINUS DIFFERENCE))
(MINUS 600 ((F) (Y)) NIL)
(DIFFERENCE 100 ((Y) (F) (X)) NIL)
(TIMES 200 ((Y) (F) (R)) (RECIP QUOTIENT))
(RECIP 700 ((F) !1 !}!{ (Z) !}) NIL)
(QUOTIENT 200 ((F) (Z) !}!{ (Z) !}) NIL)
(EXPT 850 ((X) !^!{ (Z) !}) NIL)
(SQRT 800 ((F) ! ! ! (Z) !}) NIL)
(MAT 999 ((F) (M !\!c!r! !&) !}) NIL)
(LIST 999 (!\!{ (L !\CO! ) !\!}) NIL)
(DF 999 ((APPLY makeDF)) NIL)
(INT 999 ((F) (Z) !\!, !d (Z)) NIL)
(SUM 999 ((F) !_!{ (Z) != (Z)
!}!^!{ (Z) !} (X)) NIL)
(PROD 999 ((F) !_!{ (Z) != (Z)
!}!^!{ (Z) !} (X)) NIL)
(PARTDF 999 ((F) (APPLY makePARTDF)) NIL) % EXCALC
(D 999 (!\!d! (X)) NIL) % EXCALC
(INNERPROD 999 (!\!< (L !,) !\!>) NIL) % EXCALC
(!:ps!: 999 ((APPLY make!:ps!:)) nil) % TPS
(rest!_order 999 (!{ !\!r!m! !O !} (X)) nil) % TPS
%-----------+----------+----------------------+------------------------+
));
% ----------------------------------------------------------------------
% Section 1.2 : Prefix to Infix Conversion
% ----------------------------------------------------------------------
symbolic procedure mktag(tag,prec,assf);
% analyze an operator and decide what to do
% parameters: tag ....... the term itself
% prec ...... outer precedence
% assf ...... outer associativity flag
if null tag then nil else
if atom tag then texexplode(tag) else
begin
scalar tagprec,term;
tagprec:=get(car tag,'TEXPREC) or 999; % get the operator's precedence
term:=makefunc(car tag,cdr tag,tagprec); % expand expression and if it
% is necessary, put a left and a right bracket around the expression.
if (assf and (prec = tagprec)) or (tagprec < prec)
then term:=nconc('!\!( . term , '!\!) . nil);
return(term)
end;
symbolic procedure makearg(l,s);
% collect arguments from a list <l> and put seperators <s> between them
if null l then nil
else if null cdr l then mktag(car l,0,nil)
else nconc(mktag(car l,0,nil), s . makearg(cdr l,s));
symbolic procedure makemat(m,v,h);
% make a matrix <m> and use <h> as a horizontal seperator and <v> as
% a vertical terminator.
if null m then nil else nconc(makearg(car m,h), v . makemat(cdr m,v,h));
%ff
smacro procedure istag(v,w); car v=w;
smacro procedure unary(uby); car uby;
smacro procedure binary(uby); cdr uby;
smacro procedure lcopy(a); for each x in a collect x;
symbolic procedure makefunc(op,arg,prec);
begin
scalar term,tag,a,pattern,uby;
term:=nil;
pattern:=get(op,'TEXPATT)
or ( if flagp(op,'INDEXVAR) then '((APPLY makeExcInx))
else '( (F) !\!( (L !,) !\!) ));
uby:=get(op,'TEXUBY);
while pattern do
<< tag:=car pattern; pattern:=cdr pattern;
if (atom tag) then a:=tag.nil
else if (not atom car tag) then a:=nil
else if istag(tag,'F) then
% test for unary to binary operator interchange
if (not atom car arg)and uby and (caar arg=unary(uby))
then << a:=texexplode(binary(uby)); arg:=cadar arg.cdr arg >>
else a:=texexplode(op)
else if istag(tag,'APPLY)
then << a:=apply3(cadr tag,op,arg,prec); arg:=nil >>
else if null arg then a:=nil
else if istag(tag,'X)
then << a:=mktag(car arg,prec,nil); arg:=cdr arg >>
else if istag(tag,'Y)
then << a:=mktag(car arg,prec,T); arg:=cdr arg >>
else if istag(tag,'Z)
then << a:=mktag(car arg,0,nil); arg:=cdr arg >>
else if istag(tag,'R) then
if cdr arg % more than one argument ?
then << pattern:=get(op,'TEXPATT); a:=nil >>
else << a:=mktag(car arg,prec,nil); arg:=cdr arg >>
else if istag(tag,'L)
then << a:=makearg(arg,cadr tag); arg:=nil >>
else if istag(tag,'M)
then << a:=makemat(arg,cadr tag,caddr tag); arg:=nil >>
else a:=nil;
if a then term:=nconc(term,a)
>>;
return(term)
end;
%ff
symbolic procedure makeDF(op,arg,prec); % DF operators are tricky
begin
scalar dfx,f,vvv; integer degree;
dfx:=lcopy(f:=texexplode op); degree:=0;
nconc(dfx,mktag(car arg,prec,nil)); dfx:=nconc(dfx,list '!}!{);
for each item in cdr arg do
if numberp(item) then
<< dfx:= nconc(dfx,'!^!{ .texexplode(item));
dfx:= nconc(dfx,list '!});
degree:=degree+item-1;
>>
else
<< dfx:= nconc(dfx,append(f,mktag(item,prec,nil))); degree:=degree+1
>>;
if degree>1 then
<< vvv:=nconc(texexplode(degree), '!} . cdr dfx);
rplacd(dfx,'!^!{ . vvv)
>>;
return ('!\!f!r!a!c!{ . nconc(dfx, list '!}))
end;
symbolic procedure makePARTDF(op,arg,prec); % EXCALC extension
if cdr arg then
('!_!{ . nconc(makearg(cdr arg,'!,), '!} . mktag(car arg,prec,nil)))
else ('!_!{ . nconc(mktag(car arg,prec,nil), list '!}));
smacro procedure InxExtend(item,ld,rd);
nconc(result,ld.nconc(texexplode(item),list rd));
symbolic procedure makeExcInx(op,arg,prec); % EXCALC extension
begin scalar result;
result:=nconc('!{.nil,texexplode(op));
for each item in arg do
if numberp item then
if minusp item then InxExtend(-item,'!{!}!_!{,'!})
else InxExtend(item ,'!{!}!^!{,'!}) else
if atom item then InxExtend(item ,'!{!}!^!{,'!}) else
if car item='MINUS then InxExtend(cadr item ,'!{!}!_!{,'!})
else InxExtend('! ,'!{!}!_!{,'!});
return nconc(result,'!}.nil)
end;
% The following is part of the interface to TPS.
% Andreas Strotmann, 19 Mar 93
% ps:numberp smacro required for compilation; copied over from tps.red
symbolic smacro procedure ps!:numberp u;
numberp u or (car u neq '!:ps!: and get(car u,'dname));
% fluid declaration to avoid compiler warnings
fluid '(ps!:exp!-lim);
% symbolic procedure ps!:prin!: p;
symbolic procedure make!:ps!:(op, arg, prec); % TPS interface,
% (lambda (first,u,delta,symbolic!-exp!-pt,about,atinf);
(lambda (first,u,delta,symbolic!-exp!-pt,about,atinf,texps,p);
<< % if !*nat and posn!*<20 then orig!*:=posn!*;
atinf:=(about='ps!:inf);
ps!:find!-order p;
delta:=prepf((ps!:depvar p) .** 1 .*1 .+
(negf if atinf then nil
% expansion about infinity
else if idp about then !*k2f about
else if ps!:numberp about then !*n2f about
else if (u:=!*pre2dp about) then !*n2f u
else !*k2f(symbolic!-exp!-pt:= compress
append(explode ps!:depvar p, explode '0))));
% if symbolic!-exp!-pt then prin2!* "[";
% prin2!* "{";
texps := nconc(texps, list '!\!{ );
%
for i:=(ps!:order p): ps!:exp!-lim do
<< u:=ps!:term(p,i);
if not null numr u then
<<if minusf numr u then <<u:=negsq u; % prin2!* " - ">>
texps := nconc(texps, list '!-)
>>
else if not first then % prin2!* " + ";
texps := nconc(texps, list '!+);
first := nil;
% if posn!*>55 then <<terpri!* nil;prin2!* " ">>;
if denr u neq 1 then % prin2!* "(";
texps := nconc(texps, list '!\!( );
if u neq '(1 . 1) then
% maprint(prepsq u,get('times,'infix))
texps := nconc(texps,
mktag(prepsq u,
get('times, 'texprec),
nil))
else if i=0 then % prin2!* 1;
texps := nconc(texps, list '!1);
if denr u neq 1 then % prin2!* ")";
texps := nconc(texps, list '!\!) );
if i neq 0 and u neq '(1 . 1) then % prin2!* "*";
texps := nconc(texps, list get('times,'texname) );
if i neq 0 then
% xprinf(!*p2f mksp(delta,
% if atinf then -i else i),nil,nil)
texps := (lambda i;
nconc(texps,
mktag (if (i = 1) then delta
else list('expt, delta, i),
get('times, 'texprec),
nil)))
(if atinf then -i else i);
>>
>>;
if first then % prin2!* "0";
texps := nconc(texps, list '!0 );
% if posn!*>55 then terpri!* nil;
u:=ps!:exp!-lim +1;
texps := (lambda u;
nconc(texps,
'!+ . mktag(list('rest!_order,
if (u = 1) then delta
else list('expt, delta, u)),
get('plus, 'texprec),
nil)))
(if atinf then -u else u);
%if (u=1) and not atinf and (about neq 0) then
% prin2!* " + O"
%else prin2!* " + O(";
%xprinf(!*p2f mksp(delta,if atinf then -u else u),nil,nil);
%if (u=1) and not atinf and (about neq 0) then
% prin2!* "}"
% else prin2!* ")}";
texps := nconc(texps, list '!\!} );
if symbolic!-exp!-pt then
<< %if posn!*>45 then terpri!* nil;
%prin2!* " where ";
texps := nconc(texps, list '!_!{ );
%prin2!* symbolic!-exp!-pt;
texps := nconc(texps, texexplode symbolic!-exp!-pt);
%prin2!* " = ";
texps := nconc(texps, list '!= );
%maprin about;
texps := nconc(texps, mktag(makeprefix about,
get('equal, 'texprec), nil));
texps := nconc(texps, list '!} );
%prin2!* "]"
>>;
texps
>>)
% (t,nil,nil,nil,ps!:expansion!-point p,nil);
(t,nil,nil,nil,ps!:expansion!-point(op . arg),nil,nil,op . arg);
%ff
% ----------------------------------------------------------------------
% Section 1.3 : Making a TeX Item
% ----------------------------------------------------------------------
% Properties of TeX items:
% 'CLASS ..... one of the following class specifiers
% 'ORD .... ordinary symbols
% 'LOP .... large operators
% 'BIN .... binary operators
% 'REL .... relational operators
% 'OPN .... opening symbols (left parenthesis)
% 'CLO .... closing symbols (right parenthesis)
% 'PCT .... punctuation symbols
% 'INN .... inner TeX group delimiters
% 'TEXTAG ..... one of the following lists or atoms
% <kind> .. an atom describing an 'INN class group delimiter
% (<w1> <w2> <w3>) ... where is
% <w1> ..... width for text style (cmmi10)
% <w2> ..... width for scriptstyle (cmmi8)
% <w3> ..... width for scriptscriptstyle (cmmi5)
% The parital lists of the list which is passed to makeitems have the
% following general structure:
% (<TeX-item> <class> <TeX-tag> <v1> <v2> ... )
% where is
% <TeX-item> .... the atom which actually is the TeX code
% <class> ....... the 'CLASS property as explained above
% <TeX-tag> ..... the 'TEXTAG property as explained above
% <v1> etc. ..... atoms which will be bound to specific TeX items
% by its property 'TEXNAME
% ----------------------------------------------------------------------
smacro procedure triassert(name,item); put(name,'TEXNAME,item);
smacro procedure assertl(l); for each v in l do triassert(car v,cadr v);
smacro procedure retract(name); put(name,'TEXNAME,nil);
smacro procedure retractl(l); for each v in l do retract(car v);
smacro procedure gettexitem(a); get(a,'TEXNAME) or (get(a,'CLASS)and a);
put ('TeXitem,'STAT,'RLIS); % handle argument passing for func. TeXitem
symbolic procedure TeXitem(arglist);
begin scalar x,OK,item,class,tag;
if not length(arglist)=3
then rederr "Usage: TeXitem(item,class,width-list);";
item:=car arglist; class:= cadr arglist; tag:= caddr arglist;
OK:=memq(class,'(ORD BIN REL PCT OPN CLO LOP));
if not OK then << prin2 "% illegal item class "; print class >>;
if atom tag then OK:=nil else
<< if car(tag)='LIST then tag:=cdr tag; % accept algebraic lists
for each x in tag do if not numberp x then OK:=nil
>>;
if not OK then << prin2 "% illegal width tag "; print tag >>;
if OK then
<< item:=intern(item); put(item,'CLASS,class); put(item,'TEXTAG,tag)
>>;
prin2 "% Item "; prin2 item;
if not OK then prin2 "not "; prin2 " added"; terpri();
return nil
end;
%ff
symbolic procedure makeitems(l);
for each w in l do
begin scalar iw;
iw:=intern(car w);
put(iw,'CLASS,cadr w); put(iw,'TEXTAG,caddr w);
for each v in cdddr w do triassert(v,iw);
end;
fluid '(TeXunknowncounter!*);
TeXunknowncounter!*:= 0;
symbolic procedure UnknownItem(a);
<< TeXunknowncounter!* := TeXunknowncounter!* +1;
prin2 "% non-fatal error: unknown atom "; prin2 a;
prin2 " replaced by ?_{"; prin2 TeXunknowncounter!*;
prin2 "}"; terpri();
'!? . '!_!{ . nconc(explode TeXunknowncounter!*, list '!})
>>;
symbolic procedure texexplode(a);
begin scalar b;
b:=if a and (atom a) then
(gettexitem(a)
or if numberp(a) then texcollect(explode(a))
else if stringp(a) then strcollect(explode2(a))
else texexplist(texcollect(explode2(a))));
b:=if null b then list '! else if not atom b then b else list b;
return b
end;
symbolic procedure texcollect(l);
for each el in l join
if null gettexitem(el) then UnknownItem(el)
else gettexitem(el).nil;
smacro procedure strtexitem(e);
if e='! then '!\!
else if liter(e) then e
else gettexitem(e) or UnknownItem(e) or '! ;
symbolic procedure strcollect(l);
for each el in l collect strtexitem el;
symbolic procedure texexplist(r);
begin scalar r,v;
v:=nil;
for each rl on r do
if digit(car rl) and not v then v:=rl
else if v and not digit(car rl) then v:=nil;
if v then
<< rplacd(v,car v.cdr v); rplaca(v,'!_!{); nconc(r,'!}.nil) >>;
return r
end;
%ff
makeitems('(
(! INN DMY) % no nonsense dummy item
(!{ INN BEG) % begin of a TeX inner group
(!^!{ INN SUP) % superscript
(!_!{ INN SUB) % subscript nolimits
(!{!}!^!{ INN SUP) % spread superscript
(!{!}!_!{ INN SUB) % spread subscript
(!}!{ INN SEP) % general group seperator
(!}!^!{ INN ESP) % end of group and superscript
(!}!_!{ INN ESB) % end of group and subscript
(!} INN END) % end of TeX inner group
(!\!f!r!a!c!{ INN FRC RECIP QUOTIENT) % fraction group
(!\!s!q!r!t!{ INN FRC SQRT) % square root
(!\!p!m!a!t!r!i!x!{ INN MAT MAT) % matrix group
(!& INN TAB) % horizontal tabulation
(!\!c!r! INN CR ) % vertical tabulation
(!\!n!l! INN CR ) % vertical tabulation (special)
(!\!( OPN (327680 276707 241208)) % test value
(!\!) CLO (327680 276707 241208)) % ...
(!\!{ OPN (327680 276707 241208)) % ...
(!\!} CLO (327680 276707 241208)) % ...
(!\![ OPN (0))
(!\!] CLO (0))
(!\!< OPN (254863 212082 195700))
(!\!> CLO (254863 212082 195700))
(!\!, ORD (80960))
(!\!q!u!a!d! REL (655360))
(! ORD (0)) % dummy item
(!\!r!m! ORD (0)) % dummy def of font change
(!\!i!t! ORD (0)) % dummy def of font change
(!\!b!f! ORD (0)) % dummy def of font change
(!\!h!b!o!x! ORD (0)) % dummy def of box opening
(!! ORD (182045 148367 131984))
(!? ORD (309476 247127 211630))
(!\!l!b!r!a!c!e! ORD (327681 268516 241211) !{)
(!\!r!b!r!a!c!e! ORD (327681 268516 241211) !})
(!\!l!b!r!a!c!k! ORD (182045 148367 131984) ![)
(!\!r!b!r!a!c!k! ORD (182045 148367 131984) !])
(!\!b!a!c!k!s!l!a!s!h! ORD (327681 268516 241211) !\)
(!\!% ORD (546135 430537 359544) !%)
(!\!# ORD (546135 430537 359544) !#)
(!\!& ORD (509726 402320 336788) !&)
(!@ ORD (509726 402320 336788))
(!\!_ ORD (235930) !_)
(!\!$ ORD (327681 261235 223008) !$)
(!; ORD (182045 148367 131984))
(!: ORD (182045 148367 131984))
(!. ORD (182045 148367 131984))
(!, ORD (182045 148367 131984))
(!| ORD (182045 148367 131984))
(!' ORD (183865 177267))
(!` ORD (182045 148367 131984))
(!\! ORD (218453))
%ff
% Fonts ammi10, ammi7, ammi5; ordered by index number
(!\!G!a!m!m!a! ORD (394126 317121 266467))
(!\!D!e!l!t!a! ORD (546133 451470 377742))
(!\!T!h!e!t!a! ORD (481689 395400 331866))
(!\!L!a!m!b!d!a! ORD (418702 346612 293546))
(!\!X!i! ORD (447374 366819 309020))
(!\!P!i! ORD (553870 446190 368185))
(!\!S!i!g!m!a! ORD (511090 417791 348842))
(!\!U!p!s!i!l!o!n! ORD (382293 320398 275342))
(!\!P!h!i! ORD (436906 364088 309475))
(!\!P!s!i! ORD (419430 354622 304150))
(!\!O!m!e!g!a ORD (461596 382217 322806))
(!\!a!l!p!h!a! ORD (419233 350253 299280))
(!\!b!e!t!a! ORD (370688 303376 259231))
(!\!g!a!m!m!a! ORD (353318 296277 256227))
(!\!d!e!l!t!a! ORD (273066 229467 203070))
(!\!e!p!s!i!l!o!n! ORD (266012 222822 197791))
(!\!z!e!t!a! ORD (223686 195060 178221))
(!\!e!t!a! ORD (352407 300373 261688))
(!\!t!h!e!t!a! ORD (298553 247580 216177))
(!\!i!o!t!a! ORD (231955 198883 180224))
(!\!k!a!p!p!a! ORD (377590 315392 271246))
(!\!l!a!m!b!d!a! ORD (382293 320398 275342))
(!\!m!u! ORD (394885 326314 278528))
(!\!n!u! ORD (341940 283534 244849))
(!\!x!i! ORD (327680 276707 241208))
(!\!p!i! ORD (370293 312456 270222))
(!\!r!h!o! ORD (329728 269699 232379))
(!\!s!i!g!m!a! ORD (361737 300646 258776))
(!\!t!a!u! ORD (250083 220910 200430))
(!\!u!p!s!i!l!o!n! ORD (354076 299008 259413))
(!\!p!h!i! ORD (390485 322764 275888))
(!\!c!h!i! ORD (410055 334506 283534))
(!\!p!s!i! ORD (426894 357262 304924))
(!\!o!m!e!g!a! ORD (407931 339968 290360))
(!\!v!a!r!e!p!s!i!l!o!n! ORD (312433 358776 225097))
(!\!v!a!r!t!h!e!t!a! ORD (388513 326997 281713))
(!\!v!a!r!p!i! ORD (504945 424800 359719))
(!\!v!a!r!r!h!o! ORD (329728 369699 232379))
(!\!v!a!r!s!i!g!m!a! ORD (312433 258776 225097))
(!\!v!a!r!p!h!i! ORD (465123 383749 323675))
% omitted: codes 40-47
(!0 ORD (327680 276707 241208))
(!1 ORD (327680 276707 241208))
(!2 ORD (327680 276707 241208))
(!3 ORD (327680 276707 241208))
(!4 ORD (327680 276707 241208))
(!5 ORD (327680 276707 241208))
(!6 ORD (327680 276707 241208))
(!7 ORD (327680 276707 241208))
(!8 ORD (327680 276707 241208))
(!9 ORD (327680 276707 241208))
(!. PCT (182044 160198 150186) CONS)
(!, REL (182044 160198 150186))
(!\CO! REL (182044 160198 150186))
%ff
% omitted: code 60
(!/ BIN (327680 262143 204800))
% omitted : codes 62,63
(!\!p!a!r!t!i!a!l! ORD (384341 314982 268105) PARTDF DF)
(!A ORD (491520 404866 339057))
(!B ORD (497095 406550 339569))
(!C ORD (542583 439273 363451))
(!D ORD (542583 439273 363451))
(!E ORD (468400 387026 326360))
(!F ORD (412330 331684 277845))
(!G ORD (515276 418884 348660))
(!H ORD (544768 439409 363520))
(!I ORD (288085 236475 204913))
(!J ORD (371825 302512 257706))
(!K ORD (556373 450104 371598))
(!L ORD (446008 369914 312888))
(!M ORD (635790 512227 420408))
(!N ORD (526563 424846 352142))
(!O ORD (499893 409964 343244))
(!P ORD (420750 341242 286606))
(!Q ORD (518098 424527 354622))
(!R ORD (482417 399041 335644))
(!S ORD (392760 323128 274887))
(!T ORD (382976 318122 272270))
(!U ORD (447465 366409 309179))
(!V ORD (375011 304014 260266))
(!W ORD (577991 469310 389973))
(!X ORD (533845 433811 359651))
(!Y ORD (388210 317485 270506))
(!Z ORD (429170 352256 397642))
% omitted: codes 91-96
(!a ORD (346415 291999 253770))
(!b ORD (281258 235383 207621))
(!c ORD (283610 240571 212810))
(!d ORD (341105 277890 242392))
(!e ORD (283610 240571 212810))
(!f ORD (320853 260778 224369))
(!g ORD (300980 247580 215995))
(!h ORD (377590 315392 271246))
(!i ORD (231500 191601 174762))
(!j ORD (238933 198883 177493))
(!k ORD (341181 296265 248490))
(!l ORD (195546 169756 157468))
(!m ORD (575411 479687 402318))
(!n ORD (393367 334051 288540))
(!o ORD (317667 264510 230377))
(!p ORD (329728 277435 242392))
(!q ORD (292560 245577 215995))
(!r ORD (277466 235292 208668))
(!s ORD (307200 253041 219818))
(!t ORD (234837 204799 186595))
(!u ORD (375163 319487 277162))
(!v ORD (317667 269881 236657))
(!w ORD (463303 386389 327680))
(!x ORD (361813 296732 253951))
(!y ORD (321308 273066 239388))
(!z ORD (304772 257137 225735))
% omitted: codes 123-127
%ff
% Fonts amsy10, amsy7, amsy5; not ordered.
(!+ BIN (509724 422343 354986) PLUS)
(!- BIN (509724 422343 354986) DIFFERENCE MINUS)
(!* ORD (509724 422343 354986))
(!" ORD (509724 422343 354986))
(!\!c!d!o!t! BIN (182044 160198 150186) TIMES)
(!= REL (509724 422343 354986) EQ EQUAL)
(!:!= REL (691771 550687 468772) SETQ)
(!\!s!u!m! LOP (1000000 700000 500000) SUM)
(!\!p!r!o!d! LOP (1000000 700000 500000) PROD)
(!\!i!n!t! LOP (1000000 700000 500000) INT)
(!\!l!i!m! ORD (910221 771866 678114) LIM)
(!\!s!i!n! ORD (804635 687398 612123) SIN)
(!\!c!o!s! ORD (877454 745653 657634) COS)
(!\!t!a!n! ORD (946630 800994 700869) TAN)
(!\!l!n! ORD (700000 600000 500000) LOG)
(!\!e!x!p! ORD (1001243 844685 735003) EXP)
(!\!a!r!c!t!a!n! ORD (1824539 1543734 1356227) ATAN)
(!\!w!e!d!g!e! ORD (436908 353167 309480) WEDGE)
(!\!d! ORD (364090))
));
%ff
% ----------------------------------------------------------------------
% You can choose to have some default TEXNAME properties for your
% variables. Function "trimakeset" defines a set of such default names.
% If you want to activate the set, call "TeXassertset(<setname>)" , or
% if you want to deactivate the set, call "TeXretractset(<setname>)" .
% The current <setname>s available are:
% * GREEK : lowercase greek letters
% * LOWERCASE: roman lowercase letters
% ----------------------------------------------------------------------
% handle argument passing
deflist( '((TeXassertset RLIS) (TeXretractset RLIS)), 'STAT);
symbolic procedure TeXassertset(arglist);
if not length(arglist)=1 then rederr "Usage: TeXassertset(setname);"
else begin scalar sym; sym:= car arglist;
if get('TEXSYM,sym) then
<< assertl(get('TEXSYM,sym)); prin2 "% set ";
prin2 sym; prin2 " asserted"; terpri()
>> else << prin2 "% no such set"; terpri() >>
end;
symbolic procedure TeXretractset(arglist);
if not length(arglist)=1 then rederr "Usage: TeXretractset(setname);"
else begin scalar sym; sym := car arglist;
if get('TEXSYM,sym) then
<< retractl(get('TEXSYM,sym)); prin2 "% set ";
prin2 sym; prin2 " retracted"; terpri()
>> else << prin2 "% no such set"; terpri() >>
end;
symbolic procedure trimakeset(sym,a!_set);
<<put('TEXSYM,sym,a!_set); nil>>;
trimakeset('GREEK,'(
(ALPHA !\!a!l!p!h!a! )
(BETA !\!b!e!t!a! )
(GAMMA !\!g!a!m!m!a! )
(DELTA !\!d!e!l!t!a! )
(EPSILON !\!e!p!s!i!l!o!n! )
(ZETA !\!z!e!t!a! )
(ETA !\!e!t!a! )
(THETA !\!t!h!e!t!a! )
(IOTA !\!i!o!t!a! )
(KAPPA !\!k!a!p!p!a! )
(LAMBDA !\!l!a!m!b!d!a! )
(MU !\!m!u! )
(NU !\!n!u! )
(XI !\!x!i! )
(PI !\!p!i! )
(RHO !\!r!h!o! )
(SIGMA !\!s!i!g!m!a! )
(TAU !\!t!a!u! )
(UPSILON !\!u!p!s!i!l!o!n! )
(PHI !\!p!h!i! )
(CHI !\!c!h!i! )
(PSI !\!p!s!i! )
(OMEGA !\!o!m!e!g!a! ) ));
trimakeset('LOWERCASE,'(
(A !a) (B !b) (C !c) (D !d) (E !e) (F !f) (G !g) (H !h) (I !i) (J !j)
(K !k) (L !l) (M !m) (N !n) (O !o) (P !p) (Q !q) (R !r) (S !s) (T !t)
(U !u) (V !v) (W !w) (X !x) (Y !y) (Z !z) ));
%ff
% ----------------------------------------------------------------------
% Section 2: Inserting Glue into a TeX-Item-List
% ----------------------------------------------------------------------
%
% Glue Items to be inserted between consecutive TeX-Items (similar to
% what TeX does with its items, but this table is slightly modified.)
%
% Class|ORD|LOP|BIN|REL|OPN|CLO|PCT|INN|
% -----+---+---+---+---+---+---+---+---+
% ORD | 0 | 1 |(2)|(3)| 0 | 0 | 0 | 0 |
% LOP | 1 | 1 | * |(3)| 0 | 0 | 0 |(1)|
% BIN |(2)|(2)| * | * |(2)| * | * |(2)|
% REL |(3)|(3)| * | 0 |(3)| 0 | 0 |(3)| columns: right items
% OPN | 0 | 0 | * | 0 | 0 | 0 | 0 | 0 | lines: left items
% CLO | 0 | 1 |(2)|(3)| 0 | 0 | 0 | 0 |
% PCT |(1)|(1)| * |(1)|(1)|(1)|(1)|(1)|
% INN | 0 | 1 |(2)|(3)|(1)| 0 |(1)| 0 |
% -----+---+---+---+---+---+---+---+---+
%
% The glue items and its meanings:
% 0 ......... no space
% 1 (1) ..... thin space (no space if sub-/superscript)
% 2 (2) ..... medium space (no space if sub-/superscript)
% 3 (3) ..... thick space (no space if sub-/superscript)
% * ......... this case never arises (really?)
% ----------------------------------------------------------------------
symbolic procedure makeglue(mx);
if null mx then nil else
begin
scalar id1,id2,row,col;
row:=cdr mx; id1:=car mx;
while(row) do
<< id2:=car mx; col:=car row;
while (col) do
<< put(car id1,car id2,car col);
col:=cdr col; id2:=cdr id2
>>;
row:=cdr row; id1:=cdr id1
>>
end;
makeglue('(
(ORD LOP BIN REL OPN CLO PCT INN)
( 0 1 -2 -3 0 0 0 0 )
( 1 1 0 -3 0 0 0 -1 )
(-2 -2 0 0 -2 0 0 -2 )
(-3 -3 0 0 -3 0 0 -3 )
( 0 0 0 0 0 0 0 0 )
( 0 1 -2 -3 0 0 0 0 )
(-1 -1 0 -1 -1 -1 -1 -1 )
( 0 1 -2 -3 -1 0 -1 0 )
));
smacro procedure kindof(item); get(item,'TEXTAG);
smacro procedure classof(item); get(item,'CLASS);
%ff
smacro procedure groupbeg(kind); % beginning of a group
memq(kind,'(BEG SUP SUB FRC MAT));
smacro procedure groupend(kind); (kind='END);
smacro procedure grouphs(kind); (kind='TAB);
smacro procedure groupvs(kind); % vertical group seperator
memq(kind,'(ESP ESB SEP CR));
symbolic procedure interglue(left,right,depth,nesting);
% compute the glue to be inserted between two TeX items
% parameters: left,right .......... left/right TeX item
% depth ............... superscript/subscript level
% nesting ............. depth of parenthesis level
% a glue item is a list consisting of two numbers, i.e.
% (<width> <penalty>)
% where <width> is the width of the glue in scaled points and <penalty>
% is a negative numeric value indicating 'merits' for a breakpoint.
if (null left)or(null right)or(not atom left)or(not atom right) then nil
else begin
scalar glue,lc,rc; % glue code and item classes
lc:=classof(left); rc:=classof(right); glue:=get(lc,rc);
if null(glue) then return nil;
if (left='!\CO! ) then return(list(0,-10000));
if glue<0 then if depth>0 then return nil else glue:=(-glue);
if glue=1 then return(list(80960,nesting*10 +20))
else if glue=2 then
<< if (left='!+ or left='!-) then return nil;
if (right='!+) then return(list(163840,nesting*30-390));
if (right='!- and (lc='ORD or lc='CLO))
then return(list(163840,nesting*30-210));
if (left='!\!c!d!o!t! ) then return(list(163840,nesting*10+50));
if (right='!\!c!d!o!t! ) then return nil;
return(list(163840,nesting*10))
>>
else if glue=3 then return(list(655360,nesting*10-50)) else return nil
end;
symbolic procedure insertglue(term);
% insert glue into a TeX-Item-List
begin
scalar glueitem,succ,pred,prev,backup; integer depth,nesting;
depth:=nesting:=0; succ:=nil; backup:=term;
while term do
<< pred:=succ; succ:=car term;
glueitem:=interglue(pred,succ,depth,nesting);
if glueitem then rplacd(prev,glueitem.term);
prev:=term; term:=cdr term;
if classof(succ)='INN then
<< if (groupbeg kindof succ) and
(not ((kindof(succ)='FRC) and (depth=0)))
then depth:=depth+1
else if (groupend kindof succ) and (depth>0) then depth:=depth-1
>>
else if classof(succ)='OPN then nesting:=nesting+1
else if classof(succ)='CLO then nesting:=nesting-1
>>;
return(backup)
end;
%ff
% ----------------------------------------------------------------------
% Section 3 : Line Breaking
% ----------------------------------------------------------------------
%
% How to break up a TeX item list into several independent lines
% ----------------------------------------------------------------------
% Setting break points requires "breaklists". A breaklist is a sequence
% of passive and active nodes, where each active node is followed by an
% pasive node and vice versa. Active nodes represent glue items. Passive
% nodes are integer atoms which represent the width of a sequence of or-
% dinary TeX items. This sequence must not be interspersed with glue
% items. Every breaklist consists of at least one passive node surroun-
% ded by delta nodes representing the beginning and ending of the list.
% <breaklist> ::= ( <delta-node> <passive-node> <active-node> ...
% <passive-node> <active_node> ...
% <passive-node> <delta-node>)
% <active-node> ::= ( <width> <penalty> <offset> )
% <passive-node> ::= <width>
% <delta-node> ::= ( <width> <penalty> <offset>
% <id-num> <ptr> <demerits> <indentation> )
% The breaklist will be created using the function "breaklist". Setting
% the break points (i.e. break items) in the breaklist is done using the
% functions "trybreak". During this phase, some active nodes are con-
% sidered to be "feasible" break points. Thus, they will be extended and
% named "delta nodes" furtheron. By default the first and last node in a
% breaklist are delta nodes. When trybreak has finished, the <ptr>'s of
% the delta nodes recursively pointed to from the last delta node's
% <ptr> represent the best path for breaking the whole breaklist.
% It is:
% <width> : width of item (including glue items)
% <penalty> : a numeric value which prohibits line breaking (if
% negative, line breaking will be merited)
% <offset> : distance to most previous opening bracket
% <id-num> : the identity number of the delta node {1,2,3,...}
% <ptr> : pointer to the best delta node to come from with
% respect to the minimal demerits path. note: a zero
% pointer indicates the very bottom of the stack
% <demerits> : total demerits distance to delta node which is
% pointed to by <ptr>
% <indentation>: amount of indentation when breaking at this point
% ----------------------------------------------------------------------
%ff
symbolic procedure width(item,style);
begin scalar tag;
tag:=get(item,'TEXTAG);
if null tag then tri!-error(list("cannot find item ",item),'fatal);
while (style>0)and(cdr tag) do << tag:=cdr tag; style:=style-1 >>;
return car tag or 0
end;
smacro procedure sp2mm(x); (x/186468); % scaled points to millimeters
symbolic procedure settolerance(tol);
<< if tol<0 then tol:=0 else if tol>10000 then tol:=10000;
prin2 "% \tolerance "; print tol; tolerance!*:=tol; nil
>>;
symbolic procedure setpagewidth(hsize);
% hsize can be given either in millimeters or scaled points.
<< if hsize>400 then hsize!*:=hsize else hsize!*:=hsize*186468;
prin2 "% \hsize="; prin2 sp2mm(hsize!*); prin2 "mm"; terpri();
hss!*:=float hsize!*/6; % default stretch/shrink width
hww!*:=float (3*hsize!*)/4; % optimum line width
>>;
symbolic procedure setbreak(hsize,tol);
<< settolerance(tol); setpagewidth(hsize) >>;
smacro procedure badness(hlen,ibadness);
% The badness is 100*(hlen/hss)**3, corrected for indentation badness
begin
real r;
r:=abs(hlen-hww!*)/hss!*;
return fix min(10000.0,r*r*r*100.0+ibadness)
end;
smacro procedure isglue(l); (not atom l) and (numberp car l);
smacro procedure isactive(x); not numberp x;
smacro procedure ispassive(x); numberp x;
smacro procedure isdelta(x); cdddr x;
smacro procedure addup(x); if x then eval('PLUS.x) else 0;
smacro procedure tpush(stack,item); stack:=item.stack;
smacro procedure tpop(stack);
if null stack then nil % Error
else begin scalar z; z:=car stack; stack:=cdr stack; return(z) end;
smacro procedure poke(stack,ptr,val);
if null ptr then stack:=nconc(stack,val.nil)
else << if val>car(ptr) then rplaca(ptr,val); ptr:=cdr ptr >>;
smacro procedure concatenate(l);
begin scalar r;
for each e in l do r:=nconc(r,explode e);
return compress r
end;
%ff
% ----------------------------------------------------------------------
% Section 3.1: Resolving Fraction Expressions
% ----------------------------------------------------------------------
symbolic procedure resolve(term);
% resolve a \frac{...}{...} sequence and transform it into a .../...
% sequence, where any ... argument may become parenthesized depending on
% the question if there is any non-ORD-class item within this argument.
% Furthermore, resolve a \sqrt{...} expression to \(...\)^{\frac{1}{2}}.
begin
scalar item,l,m,r,lflag,rflag;
integer depth;
l:=term; % save pointer to functor
depth:=0; m:=r:=lflag:=rflag:=nil; item:=T;
while term and item do
<< item:=car term; % take first item from list
if classof(item)='INN then % check inner class item
<< item:=kindof(item);
if groupbeg(item) then depth:=depth+1
else if groupend(item) then
if depth=1 then % outermost level ?
<< r:=term; item:=nil % save pointer to right bracket
>> % and quit using item as a flag
else depth:=depth-1
else if groupvs(item) then % if outermost level then save
if (depth=1) then m:=term % pointer to intermediate brackets
>>
else if not(classof(item)='ORD) then % non-ORD-class item ?
<< if m then rflag:=T else lflag:=T
>>;
term:=cdr term % step ahead
>>;
if car l='!\!f!r!a!c!{ then
<< if lflag and rflag
then item:=list('!/,list(655360,-10000))
else item:=list('!/);
if lflag then << rplaca(l,'!\!(); item:='!\!).item >>
else rplaca(l,'! );
if rflag then << rplaca(r,'!\!)); nconc(item,'!\!(.nil) >>
else rplaca(r,'! );
rplaca(m,car item); item:=cdr item;
if item then rplacd(m,nconc(item,cdr m))
>> else if car l='!\!s!q!r!t!{ then
<< rplaca(l,'!\!(); rplaca(r,'!\!));
rplacd(r,'!^!{ . '!1 . '!/ . '!2 . '!} . cdr r)
>>;
return(l) % return changed list pointer
end;
%ff
% ----------------------------------------------------------------------
% Section 3.2 : Create a Break List
% ----------------------------------------------------------------------
symbolic procedure breaklist(term);
begin
scalar item,result,kind,vstack,hstack,fstack,pstack,p,flag,backup;
integer depth,acc,aux,LOPw,total,indent;
p:=result:=vstack:=hstack:=fstack:=nil; backup:=term;
depth:=total:=acc:=LOPw:=indent:=0;
while term do
<< item:=car term; flag:=T; % get first item from term
if null item
then TRI!-error(list("found NIL in term : ",backup),'fatal);
if (isglue(item)) then % do we have glue ahead ?
if (depth<1) then % are we on the top level ?
<< % insert a passive node followed by an active node, clear acc.
total:=total+acc+car item; nconc(item,indent.nil);
result:=nconc(result,acc.item.nil); acc:=0
>>
else acc:=acc+car item % add up glue width
else if (classof(item)='LOP) then LOPw:=width(item,depth)
else if classof(item)='INN then
<< kind:=kindof(item);
if kind='FRC then
<< tpush(fstack,term); tpush(fstack,depth)
>>;
if groupend(kind) then % end of TeX group ?
<< depth:=depth-1; % decrement term depth
if acc>0 % if <acc> hasn't been poked
then poke(vstack,p,acc); % yet, then poke it
acc:=tpop(hstack); % get old acc value
aux:=addup(vstack); % compute vstack width
if fstack and (depth=car fstack) then
<< tpop(fstack); % first waste depth info
if aux>hww!* then % check if it doesn't fit
<< term:=resolve tpop fstack;% resolve fraction
flag:=nil % evaluate new list
>>
else % waste fraction term pointer
<< tpop(fstack); acc:=acc+aux
>>
>> else acc:=acc+aux;
p:=tpop(hstack); vstack:=tpop(hstack) % reset old status
>>
else if groupbeg(kind) then % begin of TeX group ?
<< depth:=depth+1; % increment term depth
tpush(hstack,vstack); % save current <vstack> and
tpush(hstack,p); % current <p> as well as
tpush(hstack,acc); % current <acc> to <hstack>
acc:=0; p:=vstack:=nil; % clear vertical stack
if LOPw>0 then poke(vstack,p,LOPw); LOPw:=0
>>
else if grouphs(kind) then % horizontal separator ?
<< poke(vstack,p,acc); acc:=0 % poke <acc> to <vstack>
>>
else if groupvs(kind) then % vertical separator ?
<< poke(vstack,p,acc); acc:=0; p:=vstack % reset
>>
>>
%ff
else if depth<1 then
<< aux:=width(item,depth); % add up item width
if classof(item)='OPN then
<< tpush(pstack,indent); indent:=total+acc+aux
>>;
if classof(item)='CLO then indent:=tpop(pstack) or 0;
acc:=acc+aux
>>
else acc:=acc+width(item,depth); % add up item width
if LOPw>0 then << acc:=acc+LOPw; LOPw:=0 >>;
if flag then term:=cdr term
>>;
if acc then total:=total+acc;
if (total<hsize!*) then return nil % need no breaking
else return(list(0,0,0,0,0,0,0).nconc(result,acc.
list(0,0,total,-1,0,2147483647,0).nil)) % return break list
end;
%ff
% ----------------------------------------------------------------------
% Section 3.3 : Major Line Breaking Routine
% ----------------------------------------------------------------------
smacro procedure widthof(deltanode); car deltanode;
smacro procedure penaltyof(deltanode); cadr deltanode;
smacro procedure totalof(deltanode); cadr deltanode;
smacro procedure offsetof(deltanode); caddr deltanode;
smacro procedure idof(deltanode); cadddr deltanode;
smacro procedure ptrof(deltanode); car cddddr deltanode;
smacro procedure indentof(deltanode); caddr cddddr deltanode;
smacro procedure tailof(deltanode); cddddr deltanode;
symbolic procedure offsetitem(item);
concatenate list('!\!o!f!f!{,item,'!} );
smacro procedure stepahead(ptr,val);
<< if ispassive car ptr then val:=val+car ptr else val:=val+caar ptr;
ptr:=cdr ptr
>>;
smacro procedure findindent(offt,ptr);
if offt=lastoff and ptr=lastptr then lastindent else
begin % search the deltastack for previous indentation
scalar node,p,stack; integer tot;
stack:=deltastack; p:=lastptr:=ptr; lastoff:=offt;
while stack do
<< if p=idof (node:=car stack) then
<< p:=ptrof node; tot:=totalof node;
if tot<offt then stack:=nil
>>;
if stack then stack:=cdr stack;
>>;
return(lastindent:=offt-tot+indentof node)
end;
%ff
symbolic procedure trybreak(term,brkl);
% parameters: term .... TeX item list, as created by "interglue"
% brkl .... the breaklist to be processed by this routine
begin
scalar bottom,top,base,item,deltastack,pred;
integer depth; % depth of expression when rebuilding
integer feasible,id; % number of feasible delta node
integer len,total; % current and total length so far
integer dm,basedm; % current and base demerits
integer bd; % current badness
integer penalty;
integer offset,baseoffset; % current and base parenthesis offset
integer baseptr; % pointer to best way to come from
integer indent,baseindent; % current and base indentation
integer lastoff,lastindent,lastptr; % temp. var. for speedup
real indentbadness; % correction for indentation badness
if null brkl then goto retain;
bottom:=brkl;
lastoff:=lastptr:=lastindent:=feasible:=indent:=total:=0;
while bottom do
<< top:=cdr bottom; base:=car bottom; pred:=tailof base;
id:=idof base; % id of current delta node
if penaltyof base=-10000 % break item ?
then rplaca(cdr pred,0); % new line
basedm:=cadr pred; % demerits so far
% save the delta node to the delta-stack. thus deltastack holds
% all the feasible breakpoints in reverse order.
deltastack:=base.deltastack;
len:=baseindent:=indentof(base); % indentation for this line
indentbadness:=2500.0*(float(baseindent)/float(hww!*));
baseoffset:=offsetof base;% current offset amount
baseptr:=car pred; % pointer to best node to come from
total:=total+widthof base;% correct total length
%--- debug ---
% prin2 "Base ["; prin2 id; prin2 "] basedm="; prin2 basedm;
% prin2 " ibd="; prin2 indentbadness;
% prin2 " indent="; prin2 baseindent; terpri();
%--- debug ---
%ff
while top and len<hsize!* do % loop once thru a potential line
% note that we use the local hsize instead of the full hsize
<< item:=car top;
if ispassive(item) then len:=len+item else
<< bd:=badness(len,indentbadness);
penalty:=penaltyof item;
offset:=offsetof item;
if (bd<tolerance!*) % is the breakpoint feasible?
or (bd+penalty<1) % got a break bonus ?
or (null cdr top) then % or did we reach last delta node?
<< dm:=bd*bd+basedm+penalty*abs(penalty);
if isdelta(item) then
<< pred:=tailof item;
if dm<cadr pred then % found a better path?
<< % save the pointer to best breakpoint to come from
% and the minimum demerits to reach it
rplaca(pred,id); rplaca(cdr pred,dm);
if !*TeXIndent then % save the current indentation
<< if offset>total
then indent:=offset-total+baseindent
else if offset<baseoffset
then indent:=findindent(offset,baseptr)
else indent:=baseindent;
rplaca(cddr pred,indent)
>>
>>
>>
else % create a new delta node
<< feasible:=feasible+1;
if !*TeXIndent then
if offset>total
then indent:=offset-total+baseindent
else if offset<baseoffset
then indent:=findindent(offset,baseptr)
else indent:=baseindent
else indent:=0;
rplacd(cddr item,feasible.id.dm.indent.nil)
>>;
%--- debug ---
% prin2 "-->["; prin2 idof item; prin2 "] dm="; prin2 dm;
% prin2 " bd="; prin2 bd; prin2 " p="; prin2 penalty;
% if !*TeXindent then << prin2 " ind="; prin2 indent >>; terpri();
%--- debug ---
if penalty=-10000 then top:=nil
>>;
len:=len+car item % count the length anyway
>>;
if top then top:=cdr top
>>;
%ff
rplaca(cdr base,total); % replace penalty by total width so far
bottom:=cdr bottom; % depart from this delta node
while bottom and (ispassive(car bottom) or not isdelta(car bottom))
do stepahead(bottom,total); % move to next delta node in list
>>;
bottom:=deltastack; feasible:=-1; top:=nil;
while bottom do % loop thru the delta-node stack
<< id:=idof car bottom; % id is the current id number
if id=feasible then % is this node the one pointed to?
<< feasible:=ptrof car bottom; % feasible is the new back-pointer
top:=id.top; % save the path element
>>;
bottom:=cdr bottom % step ahead
>>; % now deltastack contains the best path
deltastack:=cdr top; % in forward order
%--- debug ---
% print term; print deltastack;
%--- debug ---
if car deltastack= -1 then
<< prin2 "% Warning: no suitable way of breaking found"; terpri();
prin2 "% ======== retry with a greater tolerance..."; terpri();
prin2 "% (output will produce overfull box if printed)"; terpri()
>>;
brkl:=cdr brkl; % strip the dummy node at the list's head
%ff
% --------------------------------------------------------------------
% now remove all glue items but retain all break items
retain: % ------------------------------------------------------------
offset:=depth:=0; bottom:=term;
if brkl then brkl:=cdr brkl; % ensure first item is an active node
while term and (cdr term) do
<< item:=car term;
if isglue(item) then % if this is a glue item
if (depth=0) and brkl then % and we are on the top level
<< top:=car brkl;
if isdelta(top) then % consider delta nodes only
<< if (idof top=car deltastack) then % break point?
<< deltastack:=cdr deltastack;
%--- debug ---
% prin2 "% ["; prin2 idof top; prin2 "] ";
% prin2 sp2mm(totalof(top)+indentof(top)-offset); terpri();
% offset:=totalof(top);
%--- debug ---
if (len:=indentof top)>0
then rplacd(pred,'!\!n!l! . offsetitem(len) . cdr term)
else rplacd(pred,'!\!n!l! . cdr term)
>>
else rplacd(pred,cdr term)
>>
else rplacd(pred,cdr term);
if brkl and (cdr brkl) % check for next active node
then brkl:=cddr brkl % skip to next active node
>>
else rplacd(pred,cdr term) % remove glue item
else if classof(item)='INN then
<< if groupbeg(kindof(item)) then depth:=depth+1 else
if groupend(kindof(item)) then depth:=depth-1
>>;
pred:=term; term:=cdr term
>>;
%--- debug ---
% top:=car term; prin2 "% [-1] ";
% prin2 sp2mm(totalof(top)+indentof(top)-offset); terpri();
%--- debug ---
return(bottom)
end;
%ff
% ----------------------------------------------------------------------
% Section 4 : Output of TeX-Code
% ----------------------------------------------------------------------
symbolic procedure TeXstrlen(s);
begin
integer length;
scalar flag;
length:=0; flag:=nil;
for each c in s do
if not flag and c='!! then flag:=T
else << length:=length+1; flag:=nil >>;
return length
end;
smacro procedure newline();
if nlflag then cc:=indent
else if (cc>indent) then << terpri(); cc:=indent; nlflag:=T >>;
%ff
symbolic procedure TeXout(itemlist,flag);
if null itemlist then nil else
begin
integer cc,len,indent,ccmax,lines;
scalar item,class,tag,oldtag,lasttag,indentstack,ispd,nlflag;
ccmax:=64; cc:=indent:=lines:=0; % initializations
tag:=ispd:=nlflag:=indentstack:=nil; % initializations
prin2('!$!$); % begin TeX math group
if flag then prin2('!\!d!i!s!p!l!a!y!l!i!n!e!s!{!\!q!d!d);
terpri(); % start new line
while itemlist do
<< item:=car itemlist; itemlist:=cdr itemlist;
len:=TeXstrlen(explode(item)); oldtag:=nil; lasttag:=tag or class;
class:=classof(item); tag:=(class='INN)and(kindof(item));
%ispd:=(class='ORD)and itemlist and(classof(car itemlist)='OPN);
if (tag='MAT)or(tag='FRC)or(class='OPN) %or ispd
then newline(); % start new line
if (groupbeg(tag))or(class='OPN) then
<< tpush(indentstack,indent); % push it to the stack
tpush(indentstack,lasttag); % the reason for pushing
if (cc+cc < ccmax) % within left half of page ?
then if ((class='OPN)and(lasttag='ORD))or % predicate?
(groupbeg(tag)and not((tag='FRC)or(tag='MAT)))
then indent:=cc+len % take current position
else indent:=indent+len % compute new indentation
>>
else if (groupend(tag))or(class='CLO) then
<< oldtag:=tpop(indentstack); indent:=tpop(indentstack)
>>;
if (cc+len > ccmax) or % beyond right margin ?
(item='!+)or(item='!-)or(class='CLO) % important item?
then newline();
if nlflag then << nlflag:=nil; spaces(cc) >>;
if tag='CR then lines:=lines+1;
if not(item='! ) then prin2(item); % print the item and
cc:=cc+len; % count the characters
if groupvs(tag) or % vertical seperator ?
(groupend(tag) and % end of a large group,
((oldtag='FRC) or (oldtag='MAT)))% i.e. fraction, matrix ?
or (class='CLO) or % closing parenthesis ?
(((class='REL)or(class='BIN))and % binary/relational operator?
(cc+cc+cc > ccmax+ccmax)) % within last third of page?
or item='!, or null class
then newline()
>>;
newline(); % start final line
if flag then
if lines=0 then prin2('!\!c!r!})
else prin2('!\!N!l!}); % end multi-line output
prin2('!$!$); terpri(); return(nil) % end math group
end;
%ff
% ----------------------------------------------------------------------
% Section 5: User Interface
% ----------------------------------------------------------------------
% handle argument passing for following the functions, compelling that
% properties are used during compile time
deflist( '((TeXdisplay RLIS) (TeXlet RLIS)), 'STAT);
algebraic procedure TeXsetbreak(hsize,tol); lisp setbreak(hsize,tol);
algebraic procedure TeXtolerance(tol); lisp settolerance(tol);
algebraic procedure TeXpagewidth(hsize); lisp setpagewidth(hsize);
symbolic procedure TeXlet(arglist);
begin scalar class,sym,item;
if not length(arglist)=2 then rederr "Usage: TeXlet(symbol,item);";
sym:= car arglist; item:=intern cadr arglist; class:=classof(item);
if null class then
<< prin2 "% No such TeX symbol available"; terpri()
>>
else if (class='INN) then % prevent from TeXequiv'ing inner symbols
<< prin2 "% cannot assign inner TeX symbols yet"; terpri()
>>
else triassert(sym,item);
return nil
end;
symbolic procedure Texdisplay(arglist);
begin scalar item,tag,class;
if not length(arglist)=1 then rederr "Usage: TeXdisplay(item);";
item:=get(car arglist,'TEXNAME);
if not item then
<< prin2 "% "; prin2 car arglist; prin2 " is not defined"; terpri()
>>;
if not item then return nil;
tag:=get(item,'TEXTAG); class:=get(item,'CLASS);
prin2 "% TeX item "; prin2 item; prin2 " is of class "; prin2 class;
prin2 " and has following widths: "; terpri(); prin2 "% ";
for each w in tag do
begin real v; v:=w/65536.0; prin2 v; prin2 "pt " end;
terpri(); return nil
end;
% ----------------------- share name between both modes ----------------
symbolic operator TeXlet;
symbolic operator TeXitem;
symbolic operator TeXdisplay;
symbolic operator TeXassertset;
symbolic operator TeXretractset;
% ------------------------ Default Initializations ---------------------
<< prin2 "% TeX-REDUCE-Interface 0.50"; terpri() >>;
TeXassertset(GREEK); TeXassertset(LOWERCASE);
TeXtolerance(10); TeXpagewidth(150);
% *************** E N D O F S O U R C E C O D E **************
endmodule;
end;