reduce-historical/r36/mkhelp/minitex.red

module minitex;   % support of minimal tex syntax for
                  % reduce help file compilation.

 % author:  Herbert Melenk, ZIB Berlin

% input:    list of single characters in Latex subset syntax
%
% output:   list of rows, tagged by line number and max column 
%           length.
%
%           supported syntax elements:
%
%                ^  exponent
%                _  index
%                \frac{ ... }{ ... }
%
%                escape sequences \{ \} \_ \^ \\

fluid '(ESCAPE RAISE LOWER X0 Y0 CON);

fluid '(xlo xhi yhi ylo minitex_input minitex_page);

ESCAPE := '!\;
RAISE  := '!^;
LOWER  := '!_;

X0     := 2;
Y0     := 3;
CON    := 4;

symbolic procedure mintex_convert0 s;
   if null s then s else
   if null cdr s then s else
   if car s ='!\ and cadr s = '!\ then !$eol!$ . mintex_convert0 cddr s 
     else car s . mintex_convert0 cdr s;

symbolic procedure mintex_convert s; mintex_convert0 s;

symbolic procedure minitex(string);
  begin scalar q,w; integer r,c;
     minitex_page := for i:=-20:20 collect {i};
     minitex_input := mintex_convert string;
     q := make_chain(0,'hugo);
     if null q then return nil;
     minitex_collect q;
     for each l in minitex_page do
      if (l:=cdr l) then
      <<r:=r+1; if length(l)>c then c:=length(l);
        w:=l.w;
      >>;
     return r.c. reverse w;
  end;
     
symbolic procedure minitex_pop_char();
 if minitex_input then 
  begin scalar c;
      c := car minitex_input;
      minitex_input := cdr minitex_input;
      return c;
  end;

symbolic procedure minitex_skip(cc);
  begin scalar c;
    c := nil;
    while c neq cc do c:=minitex_pop_char();
  end;

symbolic procedure minitex_next_char();
  if minitex_input then car minitex_input;

symbolic procedure struct(type);
    {type,0,0,0};


symbolic procedure make_chain(font,term);
  begin integer indpos,xact,d,fh,
     lxlo, lxhi, lylo,lyhi,
     yindhi,yindlo;
     scalar c,cc,cell,new,end_code;
     
     fh:=1;  % font height

     end_code := 0;
     cell := struct('chain);
     
  loop:
     c := minitex_pop_char();
     cc := minitex_next_char();
     if(c = '!{ and null term) then
        <<term := '!}; goto loop>>;

     if (c = term or c = nil) then goto finish;
%    if (c = '!  ) then goto loop;
     if (c =  !$eol!$) then goto loop;

     
          % handle escaped single characters
     if(c = ESCAPE and
        (cc = '!  or cc = '!_ or cc = '!{ or cc = '!} or cc = '!$))
          then 
       <<
         indpos := -1;
          new := make_char(font,0,minitex_pop_char());
         goto after_syntax;
       >>;

     if(c = ESCAPE) then
       <<
         indpos := -1; 
         new := make_escape(font,term);
         if(new = -999) then goto loop; % /* ignore? */
       >>
       else
     if(c = LOWER or c = RAISE) then
       <<
         if(indpos > -1) then
         << xact:=indpos; yhi := yindhi; ylo = yindlo;>>
           else
         << indpos:=xact; yindhi:= yhi; yindlo := ylo;>>;

         new := make_chain(1,nil);
         if(c = RAISE) then
            d := - 1
            else
            d := + 1; 

         nth(new,Y0) := d;
         ylo := ylo+d; yhi := yhi+d;
       >>
      else
    if(c = '!{) then new := make_chain(font,'!})
      else
       << indpos := -1;
          new := make_char(font,0,c);
       >>;
  
   after_syntax:
     if not pairp new then <<end_code := new; goto finish>>;

     nth(cell,CON):=append(nth(cell,CON),{new});
     nth(new,X0) := xact;
     xact := xact + xhi;
     if(xact>lxhi) then lxhi := xact else xact:=lxhi;
     if(ylo<lylo) then lylo:=ylo;
     if(yhi>lyhi) then lyhi:=yhi;

     if(term) then goto loop;

 finish:
     ylo := lylo; yhi := lyhi;
     xlo := lxlo; xhi := lxhi;
     if pairp nth(cell,CON) then return(cell);
    end;

symbolic procedure make_char(font,cs,c);
  begin scalar cell;
    cell := struct('char);
    nth(cell,CON) := c;
    ylo := 0; yhi:=1; 
    xlo := 0; xhi:=1;
    return(cell);
  end;
 
symbolic procedure make_frac(font);
  begin scalar cell;
     scalar numr,denr,line;
     integer nxhi,dxhi,nyhi,dyhi,nylo,dylo;
     integer lxhi;
     integer yline,ydist;
     ydist := 1;

     cell := struct('chain);
     while minitex_input and car minitex_input neq '!{ do
           minitex_input:=cdr minitex_input;
     yline := 0;
     numr := make_chain(font,nil);
     nxhi := xhi; nyhi := yhi; nylo := ylo; 

      while minitex_input and car minitex_input neq '!{ do
           minitex_input:=cdr minitex_input;
     xhi := 0; xlo := 0; yhi := 0; ylo := 0;
     denr := make_chain(font,nil);
     dxhi := xhi; dyhi := yhi; dylo := ylo;

       % /* move the shorter one to the middle */
     if(dxhi > nxhi) then
     <<
        lxhi := dxhi;
        nth(numr,X0) := (dxhi - nxhi)/2;
     >>
       else
     <<
        lxhi := nxhi;
        nth(denr,X0) := (nxhi - dxhi)/2;
     >>;

     % /* make line */
     line := make_line(0,yline,lxhi,yline);

     % /* put num on top */
     nth(numr,Y0) := yline - ydist - (nyhi-1);

     % /* put denr below */
     nth(denr,Y0) := yline + ydist - dylo;

     % /* total frame */
     xlo := 0; xhi := lxhi;
     ylo := yline - ydist -(nyhi-nylo);
     yhi := yline + ydist +(dyhi-dylo);

     % /* make chain */
     nth(cell,CON) := {line,numr,denr};
     return cell;
  end;

symbolic procedure make_line(x,y,x1,y1);
 <<nth(cell,X0):=x;
   nth(cell,Y0):=y;
   nth(cell,CON):=x1;
   cell>> where cell=struct('line);

symbolic procedure make_multi(font);
  begin scalar cell,new; integer base;
    minitex_skip('!}); 
    minitex_skip('!});
    cell := struct('chain); nth(cell,CON) :=nil;
    while pairp (new :=make_chain(font,!$eol!$)) do
    << nth(cell,CON) := append(nth(cell,CON),{new});
       nth(new,Y0) := base;
       base:=base + (yhi-ylo) + 1;
    >>;
    yhi := base;
    return cell;
  end;
      
   
symbolic procedure make_end(font);
  <<minitex_skip('!}); -1>>;

%---------------------- dispatch -----------------------------------

fluid '(nullum);
nullum := struct('chain);
nth(nullum,CON):= nil;

symbolic procedure make_escape(font,term);
  if my_compare('(!f !r !a !c)) then make_frac(font)
    else 
  if my_compare('(!r !f !r !a !c)) then make_frac(font)
    else
  if my_compare('(!b !e !g !i !n { !m !u !l !t !i )) then make_multi(font)
    else
  if my_compare('(!e !n !d)) then make_end(font)
    else
  if my_compare('(!e !m)) then nullum
    else
  if my_compare('(!n !a !m !e)) then nullum
    else
  if my_compare('(!i !t)) then nullum
    else
     <<prin2 "######## \";
       for each c in minitex_input do prin2 c;
       rederr "Mini-TEX: function not implemented";
     >>;

symbolic procedure my_compare s;
  begin scalar i,c;
    i := minitex_input;
    while s and (c := minitex_pop_char()) and
      c=car s do s:= cdr s;
    if null s then return t;
    minitex_input := i;
    return nil;
  end;
     
%-------------- interprete structure: fill into page ---------------

symbolic procedure minitex_collect u;
        minitex_do(0,0,0,u);

symbolic procedure minitex_do(x,y,font,box);
   <<if null get(car box,'minitex) then
       <<print box; rederr "minitex: cannot expand object">>;
   apply(get(car box,'minitex),list(x,y,font,box));
   >>;

put('chain,'minitex,'minitex_chain);
 
symbolic procedure minitex_chain(x,y,font,box);
 << x:=x+nth(box,X0); y := y+nth(box,Y0);
   for each u in nth(box,CON) do minitex_do(x,y,font,u)
 >>;
  
put('char,'minitex,'minitex_char);

symbolic procedure minitex_char(x,y,font,box);
  begin 
    x:=x+nth(box,X0); y := y+nth(box,Y0);
    minitex_putchar(x,y,nth(box,CON));
  end;

put('line,'minitex,'minitex_line);

symbolic procedure minitex_line(x,y,font,box);
  begin
    x:=x+nth(box,X0); y := y+nth(box,Y0);
    for i:=x:x+nth(box,CON) do
       minitex_putchar(i,y,'!-);
  end;

symbolic procedure minitex_putchar(x,y,c);
  begin scalar r;
    x:=x+2;
    r:=assoc(y,minitex_page);
    while length r<x do r:=nconc(r,{'! });
    nth(r,x):=c;
  end;

end;

minitex '(a b c ^ { d e f } g);

minitex
  append(explode2 "\begin{multilineoutput}{1cm}" ,
        append({!$eol!$, 1, !$eol!$,2, !$eol!$ , 3, !$eol!$},
                 explode2 "\end{multilineoutput}"));