program coli(coliin, listing, colip, coliout, output);
(* coli: color list a set of words

  Tom Schneider
  NCI/FCRDC Bldg 469. Room 144
  P.O. Box B
  Frederick, MD  21702-1201
  (301) 846-5581 (-5532 for messages)
  permanent email: toms@alum.mit.edu
  toms@ncifcrf.gov
  http://www.lecb.ncifcrf.gov/~toms/

  National Cancer Institute
  Laboratory of Experimental and Computational Biology

 *)

label 1; (* end of program *)

const
(* begin module version *)
version = 1.02; (* of coli.p 1999 March 1
origin 1999 Feb 28 *)
updateversion = 1.00; (* defines lowest acceptable current parameter file *)
(* end module version *)

(* begin module describe.coli *)
(*
name
   coli: color list a set of words

synopsis
   coli(coliin: in, colip: in, coliout: out, output: out)

files
   coliin:  a listing of file names preceeded by a number.
     The number can simply be the date ordering, or it could
     be the file length for example

   listing:  The text listing to be converted to color.

   coliout:  PostScript to list the files.

   colip:  parameters to control the program.  The file must contain the
      following parameters, one per line:

      parameterversion: The version number of the program.  This allows the
         user to be warned if an old parameter file is used.

   output: messages to the user

description

   The input file contains a list of numbers and words, one pair per line.
   The program finds the largest number, and then divides all numbers by that
   maximum.  This range from 0 to 1 is then converted to colors.  The output
   file is PostScript code to print each of those words in color.

examples

documentation

see also
   xyplo.p

author
   Thomas Dana Schneider

bugs
   Some names like 'show' have meaning in PostScript and
   will cause this method to fail.

technical notes

*)
(* end module describe.coli *)

(* begin module coli.const *)
   colorwid = 7; (* width of color numbers *)
   colordec = 5; (* decimals of color numbers.  It is probably
      is unwise to have this larger than 5 since some postscripts
      cannot handle that properly *)
   namemax = 200; (* the longest name the program can handle *)
(* end module coli.const *)

var
   coliin, (* file used by this program *)
   colip, (* file used by this program *)
   listing, (* file used by this program *)
   coliout: text; (* file used by this program *)

(* begin module halt *)
procedure halt;
(* stop the program.  the procedure performs a goto to the end of the
   program.  you must have a label:
      label 1;
   declared, and also the end of the program must have this label:
      1: end.
   examples are in the module libraries.
   this is the only goto in the delila system. *)
begin
      writeln(output,' program halt.');
      goto 1
end;
(* end module halt version = 'delmod 6.16 84 mar 12 tds/gds'; *)

(* begin module colorfunction *)
function colorfunction(c: real): real;
(* convert the fraction c to a spectral color *)
begin
  colorfunction := 0.84 * c
end;
(* end module colorfunction *)

(* begin module coli.themain *)
procedure themain(var coliin, colip, listing, coliout: text);
(* the main procedure of the program *)
var
   blank: boolean; (* are we writing a blank character? *)
   c: char; (* a character in the list *)
   failed: boolean; (* a name was larger than namemax *)
   lw: integer; (* index to name and listing width *)
   lh: integer; (* index to name and listing height *)
   letter: integer; (* length of name *)
   maximum: real; (* the maximum n in the list *)
   n: real; (* a number in the list *)
   name: array[1..namemax] of char; (* a name in the list *)
   names: integer; (* the number of names *)
   na: integer; (* index to names *)
   parameterversion: real; (* parameter version number *)
   llx: real; (* lower left x of graphic *)
   lly: real; (* lower left y of graphic *)
   urx: real; (* upper right x of graphic *)
   ury: real; (* upper right y of graphic *)
   charwidth: integer; (* width of characters in points *)
   charheight: integer; (* height of characters in points *)
   listingwidth: integer; (* width of listing in characters *)
   listingheight: integer; (* height of listing in characters *)
begin
   writeln(output,'coli ',version:4:2);
   reset(colip);
   readln(colip, parameterversion);
   if parameterversion < updateversion then begin
      writeln(output, 'You have an old parameter file!');
      halt
   end;

   (* determine width and height of listing *)
   reset(listing);
   listingwidth := 0;
   listingheight := 0;
   while not eof(listing) do begin
      listingheight := listingheight + 1;
      lw := 0;
      while not eoln(listing) do begin
         lw := lw + 1;
         read(listing,c);
      end;
      readln(listing);
      if lw > listingwidth then listingwidth := lw;
   end;

   charwidth := 14;
   charheight := round(charwidth/0.6);
   charheight := round(charwidth* 1.2);
   llx := 14.4;
   lly := 28.90;
   urx := llx + charwidth*listingwidth;
   ury := lly + charheight*listingheight;
   rewrite(coliout);
   writeln(coliout,'%!PS-Adobe-2.0 EPSF-2.0');
   writeln(coliout,'%%Title: coli ',version:4:2);
   writeln(coliout,'%%Creator: Tom Schneider, toms@ncifcrf.gov');
   writeln(coliout,'%%BoundingBox:',
                   ' ',round(llx):5,
                   ' ',round(lly):5,
                   ' ',round(urx):5,
                   ' ',round(ury):5);
   writeln(coliout,'%%Pages: atend');
   writeln(coliout,'%%DocumentFonts:');
   writeln(coliout,'%%EndComments');
   writeln(coliout,'% define fonts');
   writeln(coliout,'/charwidth ',charwidth:1,' def % points');
   writeln(coliout,'/fontsize charwidth def');
   writeln(coliout,'/ffss {findfont fontsize scalefont setfont} def');
   writeln(coliout,'/FontForStringRegular {/Courier-Bold       ffss} def');
   writeln(coliout,'FontForStringRegular');
   writeln(coliout,'/llx ',llx:5:1,' def');
   writeln(coliout,'/lly ',lly:5:1,' def');
   writeln(coliout,'/urx ',urx:5:1,' def');
   writeln(coliout,'/ury ',ury:5:1,' def');
   writeln(coliout,'/charwidth ',charwidth:5,' def');
   writeln(coliout,'/charheight ',charheight:5,' def');

   (* find the maximum number associated with each name *)
   reset(coliin);
   n := 0;
   maximum := 0;
   names := 0;
   while not eof(coliin) do begin
      readln(coliin, n);
      if n > maximum then maximum := n;
      names := names + 1;
   end;

   reset(coliin);
   while not eof(coliin) do begin
      read(coliin, n);
{writeln(output,'n=',n:1);}
      write(coliout,'/');
      letter := 0;
      failed := false;
      while not eoln(coliin) do begin
         read(coliin,c);
         if c <> ' ' then begin
            write(coliout,c);
            if letter < namemax then begin
               letter := letter + 1;
               name[letter] := c;
            end
            else failed := true
         end
      end;
      readln(coliin);

      write(coliout,' {');
      (* write hue, saturation = 1, brightness = 1 *)
      if maximum > 0 then begin
         (* subtract from 1 to get red as most recent: *)
         write(coliout,colorfunction((n-1)/maximum):colorwid:colordec);
      end
      else begin
         write(coliout,'1');
      end;
      write(coliout,' 1 1 sethsbcolor');
      write(coliout,' (');
      for lw := 1 to letter do write(coliout,name[lw]);
      write(coliout,') show ');

      writeln(coliout,'} def');
   end;
   writeln(coliout);
   writeln(coliout);
   writeln(coliout,'llx ury charheight sub moveto');
   reset(listing);
   lh := 1;
   while not eof(listing) do begin
      blank := (listing^=' ');
      while not eoln(listing) do begin
         read(listing,c);
         case blank of
            true: if c <> ' ' then begin
               blank := false;
               writeln(coliout,') show');
            end;
            false: if c = ' ' then begin
               blank := true;
               write(coliout,' (');
            end;
         end;
         write(coliout,c);
      end;
      readln(listing);
      writeln(coliout);
      lh := lh + 1;
      writeln(coliout,'llx ury charheight ',lh:1,' mul sub moveto');
   end;
      
   writeln(coliout,'(coli ',version:4:2,' ) show');
   for na := 0 to names do begin
      writeln(coliout,colorfunction(na/names):colorwid:colordec,
                      ' 1 1 sethsbcolor (|) show');
{zzz}
   end;

   writeln(coliout,'showpage');

end;
(* end module coli.themain *)

begin
   themain(coliin, colip, listing, coliout);
1: end.