path: root/support/rnototex/flagops.pas

[INHERIT('UTILITYOPS','ARGOPS'), environment('flagops')]

MODULE FLAGOPS;          

CONST

  tab = 9;
  ncharsintab = 8;

TYPE
                     
dsrflagtype = record
	            representation : char;
	            turnedon : boolean
 	        end;
                     
                                 
dsrflagclasses = (notaflag, control, uppercase, lowercase, quote,
space, underline, bold, overstrike, hyphenate, break, period, capitalize,
endfootnote, comment, substitute);

flagtabletype = array[dsrflagclasses] of dsrflagtype;

tabrecordtype = record
	            tabread : boolean;
	            charcountintab : integer
	          end;

styletype = (undetermined, decimal, octal, hexidecimal, romanupper, romanlower,
	    romanmixed, letterupper, letterlower, lettermixed, nostyle);

enhancmentstates = (notenhanced, singlecharenhanced, enhancmentlocked);
    


VAR                                 

	lastinputchar, currentchar   : [EXTERNAL] char;
        capitalizetext, lowercasetext : [EXTERNAL] boolean;
	inputcontainstexcommands     : [EXTERNAL] boolean;
        inliteral                      : [EXTERNAL] boolean;
        totallines, totalchars        : [EXTERNAL] integer; 
        flagtable                      : [EXTERNAL] flagtabletype;
        tabrecord                      : [EXTERNAL] tabrecordtype;
	LOG                             : [EXTERNAL] text;    
        columncounter                  : [EXTERNAL] integer;
	infootnote                     : [EXTERNAL] boolean; 
	boldactive                     : [EXTERNAL] enhancmentstates;
        underlineactive                : [EXTERNAL] enhancmentstates;
        startnofillagain             : [EXTERNAL] boolean;   
        fill                            : [EXTERNAL] boolean;
        listnestlevel                 : [EXTERNAL] integer;

      

[GLOBAL] PROCEDURE beginnofill( var outfile : text  );
begin              
  if (fill) and (listnestlevel = 0) then
  begin
     writeln(outfile,'{\obeylines \obeyspaces % -  begin no fill');
     fill := false
  end
  else
  begin
    writeln(outfile,'% - RNOTOTEX obeylines, obeyspaces already active');
    writeln(    log,'% - RNOTOTEX obeylines, obeyspaces already active')
  end
end;




[GLOBAL] PROCEDURE endnofill( var outfile : text );
begin
   if (not fill) and (listnestlevel = 0) then
   begin
      writeln(outfile,'} % - end of no fill');    
      fill := true
   end
   else                                      
   begin
      writeln(outfile,'% - RNOTOTEX obeylines, obeyspaces not active');
      writeln(    log,'% - RNOTOTEX obeylines, obeyspaces not active')
   end
end;





        
[GLOBAL] PROCEDURE writeflagname( var outfile : text; f : dsrflagclasses );
begin          
  case f of
    notaflag   : write(outfile,'?????');
    control      : write(outfile,'CONTROL');
    uppercase    : write(outfile,'UPPERCASE');
    lowercase    : write(outfile,'LOWERCASE');
    quote        : write(outfile,'QUOTE');
    space        : write(outfile,'SPACE');
    underline    : write(outfile,'UNDERLINE');
    bold         : write(outfile,'BOLD');
    overstrike   : write(outfile,'OVERSTRIKE');
    hyphenate    : write(outfile,'HYPYENATE');
    capitalize   : write(outfile,'CAPITALIZE');
    endfootnote : write(outfile,'END FOOTNOTE');
    comment      : write(outfile,'COMMENT');
    substitute   : write(outfile,'SUBSTITUTE')
  end
end;



                   

 
[GLOBAL] FUNCTION isastylespecifier( arg : argument ) : styletype;
label
   routineexit;
var 
  s : pckstr;
  classification : styletype; 
begin        
   s := argliteral( arg, TRUE );
   classification := undetermined;
   if (s.body[1] = 'D') and (s.length = 1) then
   begin
     classification := decimal;
     goto routineexit
   end;
   if (s.body[1] = 'O') and (s.length = 1) then
   begin
     classification := octal;            
     goto routineexit
   end;
   if (s.body[1] = 'H') and (s.length = 1) then
   begin
     classification := hexidecimal;
     goto routineexit
   end;
   if (s.body = 'RU') and (s.length = 2) then
   begin
     classification := romanupper;
     goto routineexit
   end;
   if (s.body = 'RL') and (s.length = 2) then
   begin
     classification := romanlower;
     goto routineexit
   end;
   if (s.body = 'RM') and (s.length = 2) then
   begin
     classification := romanmixed;                           
     goto routineexit
   end;
   if (s.body = 'LU') and (s.length = 2) then
   begin
     classification := letterupper;
     goto routineexit
   end;
   if (s.body = 'LL') and (s.length = 2) then
   begin
     classification := letterlower;
     goto routineexit
   end;
   if (s.body = 'LM') and (s.length = 2) then
   begin
     classification := lettermixed;
     goto routineexit
   end;                         
   routineexit : isastylespecifier := classification
end;
                                


[GLOBAL] PROCEDURE initflagtable;
var
  f : dsrflagclasses;
begin
  for f := notaflag to substitute do
  case f of
       	notaflag : begin
	              flagtable[f].representation := blank;
	              flagtable[f].turnedon := false
	             end;
 	control    : begin
	              flagtable[f].representation := '.';   
	              flagtable[f].turnedon := true
	             end;
 	uppercase  : begin
	              flagtable[f].representation := '^';
	              flagtable[f].turnedon := true
	             end;
 	lowercase  : begin
	              flagtable[f].representation := '\';   
	              flagtable[f].turnedon := true
	             end;
 	quote      : begin
	              flagtable[f].representation := '_';  
	              flagtable[f].turnedon := true
	             end;
 	space      : begin
	              flagtable[f].representation := '#';  
	              flagtable[f].turnedon := true 
	             end;
 	underline  : begin
	              flagtable[f].representation := '&';  
	              flagtable[f].turnedon := true 
	             end;
 	bold       : begin
	              flagtable[f].representation := '*';  
	              flagtable[f].turnedon := false
	             end;
 	overstrike : begin
	              flagtable[f].representation := '%';  
	              flagtable[f].turnedon := false
	             end;
       	hyphenate  : begin
	              flagtable[f].representation := '=';  
	              flagtable[f].turnedon := false
	             end;
       	break      : begin
	              flagtable[f].representation := '|';  
	              flagtable[f].turnedon := false
	             end;
       	period     : begin
	              flagtable[f].representation := '+';  
	              flagtable[f].turnedon := false
	             end;
       	capitalize : begin
	              flagtable[f].representation := '<';  
	              flagtable[f].turnedon := false
	             end;
      endfootnote : begin
                       flagtable[f].representation := '!';
	               flagtable[f].turnedon := false
	             end;
       	comment    : begin
	              flagtable[f].representation := '!';  
	              flagtable[f].turnedon := true
	             end;
       	substitute : begin
	              flagtable[f].representation := '$';  
	              flagtable[f].turnedon := false
	             end
  end { case }
end; {initflagtable}   




[GLOBAL] FUNCTION flagclass( ch : char )  : dsrflagclasses;
var
   class : dsrflagclasses;
   foundclass : boolean;
begin     
   class := control;
   foundclass := false;
   while (class <> substitute) and ( not foundclass) do
     if (ch = flagtable[class].representation) and (flagtable[class].turnedon)then
        foundclass := true
     else                   
        class := succ(class);
   if foundclass then       
     if inliteral then
	if class = control then
	  flagclass := control
	else
	  flagclass := notaflag
      else
        flagclass := class
   else
     flagclass := notaflag
end;




[GLOBAL] PROCEDURE initcharreader(var f : text );
begin
   reset(f);
   lastinputchar := blank;
   read(f, currentchar);
   totallines := 0;
   totalchars := 0;       
   columncounter := 1;
   if ord(currentchar) = tab then
   begin
     tabrecord.tabread := true;
     tabrecord.charcountintab := ncharsintab
   end
   else
   begin
     tabrecord.tabread := false;
     tabrecord.charcountintab := 0
   end
end;




[GLOBAL] PROCEDURE getnextchar( var f : text; var gotten : boolean );

  function nexttabcolumn( startingcolumn : integer ) : integer;
  var
    i : integer;
  begin
    i := startingcolumn;
    repeat               
       i := i + 1
    until (i-1) mod ncharsintab = 0;
    nexttabcolumn := i;
    writeln(log,'nexttabcolumn input = ',startingcolumn:1,', output = ',i:1)
  end;
  
begin
   gotten := false;
   if NOT eof(f) then
   if NOT eoln(f) then
     with tabrecord do
     begin
        lastinputchar := currentchar;
        gotten := true;
        columncounter := columncounter + 1;
        if (tabread) and (charcountintab > 0) then
        begin
	   currentchar := blank;
	   charcountintab := charcountintab - 1;
	   if charcountintab = 0 then tabread := false
	end                            
	else
	begin
          totalchars := totalchars + 1;
          read( f, currentchar );
          if currentchar < blank then
          begin
             if ord(currentchar) = tab then
             begin
               tabread := true;
               charcountintab := nexttabcolumn( columncounter ) - columncounter-1;
               writeln(log,'charcountintab = ',charcountintab)
             end;
	     currentchar := blank
         end 
        end
     end
end;                    



[GLOBAL] PROCEDURE startunderline( var outfile : text; class : enhancmentstates);
begin 
  if class <> notenhanced then
    case underlineactive of
      notenhanced         : begin
	                       write(outfile,'\underline{');
	                       underlineactive := class
	                    end;
      singlecharenhanced : nullstatement;
      enhancmentlocked   : nullstatement
    end;
  underlineactive := class
end;                                             




[GLOBAL] PROCEDURE stopunderline( var outfile : text );
begin
  case underlineactive of
    notenhanced             : nullstatement;
    singlecharenhanced     : begin
	                         write(outfile,'} ');
	                         underlineactive := notenhanced
	                       end;
    enhancmentlocked        : nullstatement
  end
end;




[GLOBAL] PROCEDURE startbold( var outfile : text; class : enhancmentstates);
begin                 
  if class <> notenhanced then
    case boldactive of
      notenhanced         : begin
	                       write(outfile,'{\bf ');
	                       boldactive := class
	                    end;
      singlecharenhanced : nullstatement;
      enhancmentlocked    : nullstatement
    end;
  boldactive := class
end;                                             
                             



[GLOBAL] PROCEDURE stopbold( var outfile : text );
begin
   case boldactive of
     notenhanced           : nullstatement;
     singlecharenhanced   : begin
	                         write(outfile,'} ');
	                         boldactive := notenhanced
	                      end;
     enhancmentlocked      : nullstatement
   end
end;
                                                  



                            
[GLOBAL] PROCEDURE passblanks( var infile, outfile : text; writethem : boolean );
var 
   gotten, keeppassing : boolean;
begin                  
   keeppassing := true;    
   gotten := true;
   repeat
      if (currentchar = blank) and (gotten) then
      begin
         if writethem then write(outfile, blank );
         getnextchar(infile, gotten)
      end
      else
         keeppassing := false
   until NOT keeppassing                                  
end;
          
                            

[GLOBAL] PROCEDURE texwrite( var f : text; ch : char );
const         
  maxtrys = 2;
var
  ntrys : integer;
  written : boolean;
begin          
   ntrys := 0;     
   written := false;
   repeat
     if (inputcontainstexcommands) or (inliteral) then
       write(f, ch, error := continue)
     else
       if ch >= blank then
        if ch in ['#','$','%','&','_','^','{','}','~'] then
           write(f, '\',ch, error := continue)
        else
           if ch = '\' then
              write(f,'\backslash ', error := continue)
           else
              write(f, ch, error := continue);
     if status(f) > 0 then
     begin
       writeln(f, error := continue); 
       ntrys := ntrys + 1
     end
     else
       written := true     
   until (written) or (ntrys > maxtrys);
   if ntrys > maxtrys then
       errorexit('TEXWRITE','error writing to output')
end;



[GLOBAL] PROCEDURE writecurrentchar( var infile, outfile : text );
var
   gotten : boolean;
begin                                
    if capitalizetext then
       currentchar := capchar( currentchar );
    if lowercasetext then
       currentchar := lcchar( currentchar );
    case flagclass(currentchar) of              
        notaflag   : begin                   
	                  stopunderline( outfile );
	                  stopbold( outfile );
	                  texwrite(outfile, currentchar)
                       end;
	control      : begin                              
	                  stopunderline( outfile );           
	                  stopbold( outfile );                      
	                  texwrite(outfile, currentchar)
                       end;
 	uppercase    : begin
                       getnextchar(infile, gotten);
                       if gotten then
                       case flagclass(currentchar) of        
		         underline  : startunderline( outfile, enhancmentlocked);
	                 bold       : startbold( outfile, enhancmentlocked );
                         otherwise    texwrite(outfile, capchar(currentchar))
                       end
	               end;
 	lowercase    : begin                                   
                       getnextchar(infile, gotten);
                       if gotten then
	               case flagclass(currentchar) of
		         underline  : begin
	                                if underlineactive <> notenhanced then 
	                                   write(outfile,'} ');
	                                underlineactive := notenhanced
	                              end;
	                 bold       : begin
                                        if boldactive <> notenhanced then
 	                                   write(outfile,'} ');
	                                boldactive := notenhanced
	                              end;
                         otherwise    texwrite(outfile, lcchar(currentchar))
                         end
	               end;                   
 	quote        : begin
	               getnextchar(infile, gotten);
                       if gotten then      
	                texwrite(outfile, currentchar )
	              end;
 	space        : write(outfile,'\ ');
 	underline    : begin                              
                       getnextchar(infile, gotten );
                       if gotten then
                       begin
                         startunderline( outfile, singlecharenhanced);
	                 texwrite(outfile, currentchar)
                       end
	               else
	                 texwrite(outfile, currentchar)
                      end;
 	bold         : begin
	                getnextchar(infile, gotten);
                        if gotten then
                        begin
                           startbold( outfile, singlecharenhanced);
	                   texwrite(outfile, currentchar)
	                end
	                else
	                  texwrite(outfile, currentchar)
	               end;
 	overstrike   : begin
	                 getnextchar(infile, gotten);
                         if gotten then
                         begin
	                   startbold( outfile, singlecharenhanced);
	                   texwrite(outfile, currentchar)
	                 end
	                 else
	                   texwrite(outfile, currentchar)
	               end;
       	hyphenate    : write(outfile,'--');
       	break        : writeln(outfile,'\linebreak');
       	period       : write(outfile,'\nonfrenchspacing ');
       	capitalize   : begin
	                 getnextchar( infile, gotten);
	                 if gotten then
	                    texwrite(outfile, capchar(currentchar))
	               end;  
        endfootnote : begin
	                if (columncounter = 1) and (infootnote) then
	                begin
                            if not fill then
	                       endnofill( outfile );
	  	            writeln(outfile,'} % - end of footnote');
	                    writeln(    log,'} % - end of footnote');
                            infootnote := false;
	                    if startnofillagain then
	                    begin
	                       startnofillagain := false;
	                       beginnofill( outfile )
	                    end
	                end                                         
	                else
	                    texwrite(outfile, currentchar)
	               end;
       	comment    : begin
                       if flagclass(lastinputchar) = control then
	                      write(outfile,'% ')
                        else
	                   texwrite(outfile,currentchar)
	             end;
       	substitute : texwrite(outfile, currentchar)
  end { case }
end;
                                             

                        

[GLOBAL] PROCEDURE newline( var infile, outfile : text; putcrlf : boolean );
var                                                               
  gotten : boolean;
begin                   
   if eoln(infile) then 
   begin
     readln(infile);
     totallines := totallines + 1;
     columncounter := 1
   end;
   if putcrlf then 
     writeln(outfile);
   while (eoln(infile)) and (not eof(infile)) do
   begin  
     readln(infile);
     writeln(outfile);  
     columncounter := 1;                            
     totallines := totallines + 1
   end;                                      
   if not eof(infile) then
   begin 
     read(infile, currentchar);       
     totalchars := totalchars + 1;
     lastinputchar := blank
   end;                        
   if ord(currentchar) = tab then
   begin                                             
      tabrecord.charcountintab := ncharsintab;
      tabrecord.tabread := true
   end
   else
   begin
     tabrecord.charcountintab := 0;
     tabrecord.tabread := false
   end;
   if currentchar < blank then currentchar := blank
end;






[GLOBAL] PROCEDURE changeflagchar( flag : dsrflagclasses; newchar:char);
begin
   flagtable[flag].representation := newchar;
   write(log,'[internal flag representation change for ');
   writeflagname(log, flag);
   writeln(log,' to "',newchar,'"]')
end;

    

[GLOBAL] PROCEDURE turnflagon( flag : dsrflagclasses );
begin
   flagtable[flag].turnedon := true;
   write(log,'[internal flag ');
   writeflagname(log, flag);
   writeln(log,' enabled]')
end;
                                    


[GLOBAL] PROCEDURE turnflagoff( flag : dsrflagclasses );
begin
  flagtable[flag].turnedon := false;
  write(log,'[internal flag ');
  writeflagname(log, flag);
  writeln(log,' disabled]')
end;




[GLOBAL] PROCEDURE texwritearg( var outfile : text; arg : argument );
var
  s : pckstr;
  i, l : integer;
begin
  s := argliteral( arg, false );
  l := length( s );
  for i := 1 to l do  texwrite(outfile, s.body[i]);
  write(outfile, blank)
end;


END.