with text_io;
use text_io;
--**********************************************************
--  Conversion from troff to HTML                          *
--  Version 1: 15/6/95                                     *
--  Update     16/6/95 Table processing                    *
--             13/7/95 To use only standard TEXT_IO packge *
--             27/6/96 Table processing <table></table>    *
--             19/8/96 Cater for \fP.                      *
--                     Bug in handling blank-lines fixed(?)*
--                     Option to switch-off eqn $$ added   *
--                     (i.e. `directives' .EO (eqn on)     *
--                                        .NE (No Eqn)     *
--                      Latter is default)                 *
--            21/8/96 Couple of minor bugs fixed.          *
--**********************************************************
--  Paul E. Dunne;                                         *
--  Dept. of Comp. Sci.                                    *
--  Univ. of Liverpool                                     *
--  Liverpool L69 3BX                                      *
--  Great Britain     ; e-mail ped@uk.ac.liv.csc           *
--                      http//:www.csc.liv.ac.uk/users/ped *
--**********************************************************
procedure troff_to_html is
  text : string(1..255);
  length : integer;
  directive : integer;
  nh_number : integer:=1;
  pic_count : integer:=1;
  anch_count : integer:=1;
  ip_level : boolean := false;
  roman : constant character :='R';
  italic: constant character :='I';
  bold  : constant character :='B';
  courier  : constant character :='T';
  previous  : constant character :='P';
  eqn_on : boolean := false;
  --********************************
  -- List of Recognised Directives *
  --********************************
  nh : constant integer :=1;
  sh : constant integer :=2;
  ul : constant integer :=3;
  lp : constant integer :=4;
  pp : constant integer :=5;
  ip : constant integer :=6;
  ce : constant integer :=7;
  ft : constant integer :=8;
  ds : constant integer :=9;
  de : constant integer :=10;
  eq : constant integer :=11;
  ps : constant integer :=12;
  so : constant integer :=13;
  br : constant integer :=14;
  sp : constant integer :=15;
  ts : constant integer :=16;
  ne : constant integer :=17;
  eo : constant integer :=18;
  --***********************************
  cfont : character := roman;   -- Current font
  --*******************************************************
  -- Function to convert positive integer to string       *
  --*******************************************************
  function itos ( x : in integer; width : integer ) return string is
   s : string(1..255);
   clen, len : integer ;
   d : integer;
   r : integer;
   dist : constant integer := character'pos('0');
   begin
     if x=0 then
      s(1):='0'; len:=1;
     else
       len:=0; r:=x;
       while r > 0 loop
         d := r - 10*(r/10); r:= r/10;
         len:=len+1;
         if len > 1 then
           s(1..len) := character'val(d+dist)&s(1..len-1);
         else
           s(1) := character'val(d+dist);
         end if;
       end loop;
     end if;
     if len < width then
       clen := len;
       for i in len+1 .. width loop
         s(1..clen+1) := s(1..clen)&' ';
         clen := clen+1;
       end loop;
       len := clen;
     end if;
     return s(1..len);
   end itos;
  --*******************************************************
  -- Identify directive in text line                      *
  --*******************************************************
  function find_directive ( txt : string) return integer is
    error : constant integer := 0;
    begin
      if txt(1..3)=".NH" then
        return nh;
      elsif txt(1..3)=".SH" then
        return sh;
      elsif txt(1..3)=".ul" then
        return ul;
      elsif txt(1..3)=".LP" then
        return lp;
      elsif txt(1..3)=".PP"  then
        return pp;
      elsif txt(1..3)=".IP" then
        return ip;
      elsif txt(1..3)=".ce" then
        return ce;
      elsif txt(1..3)=".ft" then
        return ft;
      elsif txt(1..3)=".DS" then
        return ds;
      elsif txt(1..3)=".DE" then
        return de;
      elsif txt(1..3)=".PS" then
        return ps;
      elsif txt(1..3)=".so" then
        return so;
      elsif txt(1..3)=".EQ" then
        return eq;
      elsif txt(1..3)=".br" then
        return br;
      elsif txt(1..3)=".sp" then
        return sp;
      elsif txt(1..3)=".TS" then
        return ts;
      elsif txt(1..3)=".NE" then
        return ne;
      elsif txt(1..3)=".EO" then
        return eo;
      end if;
      return error;
    end find_directive;
  --****************************************************
  --  Determine if character is viewable in HTML       *
  --****************************************************
  function printable ( x : character ) return boolean is
     begin
       if x in 'A'..'Z' then
         return true;
       elsif x in 'a'..'z' then
         return true;
       elsif x in '0'..'9' then
         return true;
       elsif x=',' or x='.' or x=';' or x=':' then
         return true;
       elsif x='(' or x=')' or x='{' or x='}' then
         return true;
       elsif x='*' or x='+' or x='-' or x='/' then
         return true;
       elsif x='[' or x=']' or x='|' or x='?' or x='=' then
         return true;
       elsif x=' ' then
        return true;
       else
         return false;
       end if;
     end printable;
  --****************************************************
  -- The following procedure attempts to layout an EQN *
  -- expression. Its operation is extremely crude and  *
  -- the results may not be entirely satisfactory, so  *
  -- that editing of the HTML output is needed.        *
  --****************************************************
  procedure process_equation_badly ( txt : string; len : integer) is
    char_count : integer:=txt'first;
    begin
      while char_count<=len-1+txt'first loop
         if char_count+4<=len-1+txt'first then
            if txt(char_count..char_count+4)=" sup " then
              put("^");
              char_count:=char_count+5;
            elsif txt(char_count..char_count+4)=" sub " then
              put("^-");
              char_count:=char_count+5;
            end if;
         end if;
         if txt(char_count)='~' or txt(char_count)='^' then
           put(" ");
           char_count:=char_count+1;
         elsif txt(char_count)='&' then
           put("&amp"); 
           char_count:=char_count+1;
         elsif txt(char_count)='>' then
           put("&gt"); 
           char_count:=char_count+1;
         elsif txt(char_count)='<' then
           put("&lt"); 
           char_count:=char_count+1;
         elsif printable(txt(char_count)) then
           put(txt(char_count));
           char_count:=char_count+1;
         else
           char_count:=char_count+1;
         end if;
        end loop;
     end process_equation_badly;
  --******************************************************************
  -- Process a line of input text, to deal with accents, special     *
  -- characters in HTML (e.g. &), and some in-line directives from   *
  -- troff, such as font changes.                                    *
  --******************************************************************     
  procedure check_and_process_in_line( txt : string; len : integer) is
    char_count : integer :=1;
    dir        : character;
    font       : character;
    mark,letter : character;
    equation : boolean := false;
    span : integer;
    begin
      while char_count <= len loop
         -- Process some in-line directives
         -- 1. Change of font to Italic, Bold or Roman
         -- 2. Diacritical marks: umlaut, grave, acute
         if txt(char_count)='\' then
           dir := txt(char_count+1);
           if dir='f'   then
             font:=txt(char_count+2);
             if font='C' then font:=courier; end if;
             if font=previous and cfont/=roman then
               if cfont=courier then
                 put("</tt>");
               else
                put("</"&cfont&">");
               end if;
               cfont:=roman;
             elsif cfont/=roman then 
               if cfont=courier then
                 put("</tt>");
               else
                put("</"&cfont&">");
               end if;
               cfont:=roman;
             else
               if font/=roman then
                 if font=courier then
                   put("<tt>");
                 else
                  put("<"&font&">");
                 end if;
                 cfont:=font;
               end if;
             end if;
             char_count:=char_count+3;
           elsif dir='*' then
              mark:=txt(char_count+2);
              letter:=txt(char_count+3);
              put("&"&letter);
              if mark=':' then put("uml"); end if;
              if mark=character'val(39) then put("acute"); end if;
              if mark='`' then put("grave"); end if;
              char_count:=char_count+4;
            elsif dir='(' then
              if txt(char_count+2..char_count+3)="em" then
                put('-');
              elsif txt(char_count+2..char_count+3)="sq" then
                put("Q.E.D.");
              end if;
              char_count:=char_count+4;
            else
             char_count:=char_count+2;
           end if;
         elsif txt(char_count)='$' and eqn_on then
           if txt(char_count+1)='^' then
             equation := true; put("$ "); char_count:=char_count+2;
           elsif equation then
             equation := false; put(" $"); char_count:=char_count+1;
           else
            span:=char_count+1;
            while txt(span)/='$' loop
              span:=span+1;
            end loop;
            if cfont/=roman then put("</"&cfont&">"); end if;
            cfont:=italic;
            put("<i>");
            process_equation_badly(txt(char_count+1..span-1),span-char_count-1);
            put("</i>"); cfont:=roman;
            char_count:=span+1;
           end if;
         elsif txt(char_count)='$' and (not eqn_on) then
            put('$'); char_count:=char_count+1;
         elsif txt(char_count)='<' then
            put("&lt");
           char_count:=char_count+1;
         elsif txt(char_count)='>' then
            put("&gt");
           char_count:=char_count+1;
         elsif txt(char_count)='&' then
            put("&amp");
           char_count:=char_count+1;
         else
           put(txt(char_count));
           char_count:=char_count+1;
         end if;
      end loop;
      new_line;
    end check_and_process_in_line;
  --*************************************************
  -- Layout a table description                     *
  --*************************************************
  --                                                *
  -- This should be O.K. provided that you don't    *
  -- expect it to be too clever, e.g. single column *
  -- entries spanning more than one row, eqn in     *
  -- tables, changes of font.                       *
  --*************************************************
  procedure process_table_description is
    tabchar : character := character'val(9);
    --*******************************************
    -- Determine tab character separating       *
    -- input columns (if one specified).        *
    -- Default is tbl default, i.e. TAB         *
    --*******************************************
    function pick_up_tab_char return character is
      text : string(1..255);
      len  : integer;
      i : integer:=1;
      tab_not_found : boolean := true;
      begin
        get_line(text,len);
        while (i<=len-2) and tab_not_found loop
           if text(i..i+2)="tab" then
             tab_not_found := false;
             i:=i+4;     -- to find tab character indicator
           else
             i:=i+1;
           end if;
        end loop;
        if tab_not_found then
          return character'val(9);
        else
          return text(i);
        end if;
    end pick_up_tab_char;
    --***************************************************************
    -- Strip out column description information                     *
    --***************************************************************
    procedure strip_column_descriptions is
      text : string(1..255);
      len  : integer;
      desc_completed : boolean := false;
      flag : boolean :=false;
      procedure kill_trailing_spaces ( st : in string;
                                       ln : in out integer;
                                       flag : in out boolean ) is
        begin
          if st(ln) = ' ' then
            while st(ln) = ' ' loop
              ln := ln-1;
              if ln = 0 then 
                flag:=true; exit;
              end if;
            end loop;
          end if;
        end kill_trailing_spaces;
      begin
        while not desc_completed loop
           get_line(text,len); flag:=false;
           kill_trailing_spaces(text,len,flag);
           if not flag then
             if text(len)='.' then
               desc_completed := true;
             end if;
           end if;
        end loop;
    end strip_column_descriptions;
    --***************************************************************
    -- Output body of the table                                     *
    --***************************************************************
    procedure do_table( tabmark : character) is
      text : string(1..255);
      len  : integer;
      --*************************************************************
      -- Strip unacceptable characters from line of text.           *
      --*************************************************************
      procedure strip_unrecognised ( t : in out string;
                                     len : in out integer;
                                     tabmark : character) is
        temp_line : string(1..len);
        new_len   : integer;
        begin
          new_len:=1;
          for i in 1..len loop
            if (printable(t(i)) or t(i)=tabmark) and t(i)/='|' then
             temp_line(new_len):=t(i);
             new_len:=new_len+1;
            end if;
          end loop;
          len:=new_len-1;
          t(1..len):=temp_line(1..len);
        end strip_unrecognised;
      --**********************************************************
      begin
        get_line(text,len);
        while text(1..3) /= ".TE" loop
         strip_unrecognised(text,len,tabmark);
         --*******************************************************
         -- Ignore single character lines since these must be '='*
         -- or '_' format indicators.                            *
         --*******************************************************
         if len > 1 then
           put("<tr>"); put("<td>");
           for i in 1..len loop
             if text(i)=tabmark then
                put("</td><td>");
             else
                put(text(i));
             end if;
           end loop;
           put_line("</tr>");
         end if;
         get_line(text,len);
        end loop;
    end do_table;
    --***************************************************************
    --  Main Body - table processing procedure                      *
    --***************************************************************
    begin
      tabchar := pick_up_tab_char;
      strip_column_descriptions;
      put_line("<table border=1 rules=all>"); put_line("<tbody>");
      do_table (tabchar);
      put_line("</tbody>"); put_line("</table>");
    end process_table_description;
  --*************************************************
  --  Main Program Body                             *
  --*************************************************
  begin
    put_line("<html>");
    loop
       get_line(text,length);
       --if length=0 then 
         --if end_of_file then 
           --exit;
         --else
           --length:=3; text(1..3):=".LP";
         --end if;
       --end if;
       if text(1)='.' then
         directive:=find_directive(text);
         if directive=nh or directive=sh then
          put("<h2>");
          get_line(text,length); 
          if directive=nh then
            put(itos(nh_number,3));
            put(" ");
            nh_number:=nh_number+1;
          end if;
          if text(1..3)=".so" then
           put("<a href="); put('"'); put(text(5..length)); put('"'); put('>');
           put("anchor"); put(itos(anch_count,0));
           put_line("</a>"); anch_count:=anch_count+1;
          else
           check_and_process_in_line(text,length);
          end if;
          put_line("</h2>");
         elsif directive=ul then
          put("<i>"); cfont:=italic;
          get_line(text,length); 
          check_and_process_in_line(text,length);
          put_line("</i>"); cfont:=roman;
         elsif directive=lp or directive=pp then
           if ip_level then 
             put_line("</ul>");
             ip_level:=false;
           else
             put_line("<p>");
           end if;
         elsif directive=ip then
           if ip_level then
             put_line("<li>");
           else
             put_line("<ul>");
             put_line("<li>");
             ip_level:=true;
           end if;
         elsif directive=ce then
           put_line("<p>");
           put("<h3>");
           get_line(text,length); 
           check_and_process_in_line(text,length);
           put_line("</h3>");
         elsif directive=ds then
           put_line("<p>");
           put_line("<pre>");
         elsif directive=de then
           put_line("</pre>");
         elsif directive=eq then
           put_line("<p>");
           put_line("<pre>");
           put_line("<I>");
           get_line(text,length);
           while text(1..3)/=".EN" loop
              text(2..length+1):=text(1..length);
              if text(2..7) /= "define" then 
                process_equation_badly(text(2..length+1),length);
              end if;
              get_line(text,length);
           end loop;
           put_line("</I>");
           put_line("</pre>");
           put_line("<p>");
         elsif directive=ps then
           put_line("<p>");
           put("<img src = "); put('"'); 
           put("picture"); put(itos(pic_count,0));
           put('"'); put('>'); new_line;
           pic_count:=pic_count+1;
           get_line(text,length);
           while text(1..3)/=".PE" loop
              get_line(text,length);
           end loop;
           put_line("<p>");
         elsif directive=so then
           put("<a href="); put('"'); put(text(5..length)); put('"'); put('>');
           put("anchor"); put(itos(anch_count,0));
           put_line("</a>"); anch_count:=anch_count+1;
         elsif directive=br or directive=sp then
           put_line("<p>"); 
         elsif directive=ts then
            process_table_description;
         elsif directive=ne then
            eqn_on := false;
         elsif directive=eo then
            eqn_on := true;
         end if;
       else
         check_and_process_in_line(text,length);
       end if;
       for i in 1..length loop
         text(i) := character'val(0);
       end loop;
       length:=0;
     end loop;
     if ip_level then put_line("</ul>"); end if;
  exception when end_error =>
    put_line("</html>");
end troff_to_html;