program vr(input, output);
(* vr: Determine the version number and file name of a file.

  Dr. Thomas D. Schneider
  National Cancer Institute
  Laboratory of Experimental and Computational Biology
  Molecular Information Theory Group
  Frederick, Maryland  21702-1201
  toms@ncifcrf.gov
  permanent email: toms@alum.mit.edu (use only if first address fails)
  http://www.lecb.ncifcrf.gov/~toms/

  module libraries: prgmod.p *)

label 1; (* the end of the program *)

const
(* begin module version *)
   version = 1.01; (* of vr.p 2005 Jan 26
2005 Jan 26, 1.01: fix documentation
2005 Jan 26, 1.00: origin from verbop
*)
(* end module version *)

(* begin module describe.vr *)
(*
name
   vr: Determine the version number and file name of a file.

synopsis
   vr(input: inout, output: out)

files

   input: a program source code, with a version constant in the form
       "version = " followed by a real number.

   output: the new version number and file name are reported on two lines.

description

   This program obtains the version number and file name.

   The file is expected to have a line of the form:

   version = 1.23 of filename 2005 Jan 26

   1.23 corresponds to the version of the file.
   filename is the exact name of the file.
   The filename is identified as the first word after the 'of'.

examples

   Obtain the version number:

      vr < vr.p | head -1

   Obtain the file name number:

      vr < vr.p | tail -1

documentation

see also
   ver.p
   verbop.p

author
   Thomas Schneider

bugs
   none known

technical notes

*)
(* end module describe.vr *)


(* begin module interact.const *)
(* begin module string.const *)
      maxstring = 2000; (* the maximum string *)
(* end module string.const version = 5.11; (@ of prgmod.p 2005 Jan 19 *)
(* end module interact.const version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module filler.const *)
      fillermax = 50; (* the size of the filler array for a string *)
(* end module filler.const version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

type
(* begin module interact.type *)
(* begin module string.type *)
   stringptr = ^string; (* pointer to a string *)
   string = record (* a string of characters *)
      letters: array[1..maxstring] of char; (* the letters in the string *)
      length: integer; (* the number of characters in the string *)
      current: integer; (* the letter we are working on *)
      next: stringptr; (* the next string in a series *)
   end;
(* end module string.type version = 5.11; (@ of prgmod.p 2005 Jan 19 *)
(* end module interact.type version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module trigger.type *)
      trigger = record (* an object to be searched for *)
         seek: string; (* the characters looked for *)
         state: integer; (* how close to triggering we are *)
         skip: boolean; (* trigger not found- skip the line *)
         found: boolean (* the trigger was found *)
      end;
(* end module trigger.type version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module filler.type *)
      (* the following is an array used to fill a string.
      it is convenient to have it much shorter than the maxstring, so that
      it is easy to fill the string using procedure fillstring.
      the user must declare the value of constant fillermax. *)
      filler = packed array[1..fillermax] of char;
(* end module filler.type version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

{var}
(* begin module vr.var *)
(* end module vr.var *)

(* 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 = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module skipblanks *)

(* 2003 July 31: tab is considered a blank character *)

function isblank(c: char): boolean;
(* is the character c blank or tab? *)
begin
   isblank := (c = ' ') or (c = chr(9))
end;

procedure skipblanks(var thefile: text);
(* skip over blanks until a non-blank, or end of line, is found *)
begin
   while isblank(thefile^) and not eoln(thefile) do get(thefile);
end;

procedure skipnonblanks(var thefile: text);
(* skip over nonblanks until a blank, or end of line, is found *)
begin
   while (not isblank(thefile^)) and not eoln(thefile) do get(thefile);
end;

procedure skipcolumn(var thefile: text);
(* skip over a data column *)
begin
   skipblanks(thefile); skipnonblanks(thefile)
end;
(* end module skipblanks version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module interact.clearstring *)
(* begin module clearstring *)
procedure clearstring(var ribbon: string);
(* empty the string *)
var   index: integer; (* to the ribbon *)
begin (* clearstring *)
      with ribbon do begin
         for index := 1 to maxstring do letters[index] := ' ';
         length := 0;
         current := 0;
         next := nil;
      end
end; (* clearstring *)
procedure initializestring(var ribbon: string);
(* start the string with a nil pointer.   This routine
should be called before doing linked list work.  This allows
the standard string routines to clear the string without
killing the pointer. *)
begin (* initializestring *)
   clearstring(ribbon);
   ribbon.next := nil;
end; (* initializestring *)
(* end module clearstring version = 5.11; (@ of prgmod.p 2005 Jan 19 *)
(* end module interact.clearstring version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module filler.fillstring *)
procedure fillstring(var s: string; a: filler);
(* this procedure makes it reasonably easy to fill the string s with
characters.  one calls the procedure as: *)
(*                           1         2         3         4         5 *)
(*                  12345678901234567890123456789012345678901234567890 *)
(*   fillstring(s, 'this-is-the-string                                ');
the two comments make it easy to line the characters up. also, for this
example, it was assumed that the length of filler as defined by the
constant fillermax was 50. *)
var
      length: integer; (* of the string without trailing blanks *)
      index: integer; (* of s *)
begin (* fillstring *)
      clearstring(s);
      length := fillermax;
      while (length > 1) and (a[length] = ' ') do length := pred(length);
      if (length = 1) and (a[length] = ' ') then begin
         writeln(output, 'fillstring: the string is empty');
         halt
      end;

      for index := 1 to length do s.letters[index] := a[index];
      s.length := length;
      s.current := 1
end; (* fillstring *)
(* end module filler.fillstring version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module filler.filltrigger *)
procedure filltrigger(var t: trigger;
                      a: filler);
(* fill the trigger t *)
begin (* filltrigger *)
         fillstring(t.seek,a)
end; (* fillstring *)
(* end module filler.filltrigger version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module trigger.proc *)
(* this module allows one to scan a series of characters, as from
an array or a file, and to "trigger" or detect a simple string
in the series.  the advantage of the trigger is that several triggers
can "observe" a stream of characters at once, each looking for a
different thing.
some other modules required: interact.const, interact.type *)

procedure resettrigger(var t: trigger);
(* reset the trigger to ground state *)
begin (* resettrigger *)
      with t do begin
         state := 0;
         skip := false;
         found := false
      end
end; (* resettrigger *)

procedure testfortrigger(ch: char; var t: trigger);
(* look at the character ch.
   if it is part of the trigger (at the current trigger state),
       then the trigger state goes higher.
   if it is not part of the trigger then the trigger state is reset,
      skip is true and one should skip onward to find the trigger.
   if the trigger is found, found is true.
1996 Sep 12: Bug found!  In the case of a trigger "ab", the program
used to miss it for situations like "aab".  This was because at the
first a it would step up.  Then it would see the second a and recognize
that was not part of ab.  It would fail to realize that it could be
the start of a new one.  The code now accounts for that possibility. *)
begin (* testfortrigger *)
      with t do begin
         state := succ(state);
{
writestring(list,seek);
writeln(list,'testfortrigger seek.letters[',state:1,']:',
seek.letters[state],' ch:',ch);
}
         if seek.letters[state] = ch
         then begin
            skip := false;
            if state = seek.length then found := true
                                   else found := false
         end
         else begin
            (* it failed.  But wait!  It could be the beginning
            of a NEW trigger string! *)
            if seek.letters[1] = ch then begin
               state := 1;
               skip := false;
               found := false
            end
            else begin (* reset trigger *)
               state := 0;
               skip := true;
               found := false
            end
         end
      end
end; (* testfortrigger *)
(* end module trigger.proc version = 5.11; (@ of prgmod.p 2005 Jan 19 *)

(* begin module vr.capture *)
procedure capture(var field: text;
                  var rabbit: real;
                  var thisprogram: text);
(* capture the rabbit in the field (ie, pickup the version number),
thisprogram is the output made so far) *)
begin (* capture *)
      (* galump across the field in search of a hole *)
      while (not eoln(field)) and (field^ = ' ')
         do get(field);

      (* is there a rabbit? *)
      if field^ in ['-','0'..'9'] (* poke a stick in the hole *)
      then read(field, rabbit) (* got it - yum *)
      else begin (* nothing edible *)
         writeln(output,' version must be a real number'); (* scream *)
         halt (* die of starvation *)
      end
end; (* capture - do you think i overdid this one? *)
(* end module vr.capture *)

(* begin module vr.themain *)
procedure themain;
(* the main procedure of the program *)
var
   t: trigger; (* the version trigger *)
   anof: trigger; (* a trigger for 'of' *)
   theversion: real; (* the version and the incremented value *)
begin
(*
      writeln(output, ' vr ', version:4:2);
*)

     (*                     1         2         3         4         5 *)
     (*           12345678901234567890123456789012345678901234567890 *)
   filltrigger(t, 'version =                                         ');

     (*                        1         2         3         4         5 *)
     (*               12345678901234567890123456789012345678901234567890 *)
   filltrigger(anof, 'of                                                ');

   resettrigger(t);
   repeat
      testfortrigger(input^, t);
      get(input);
   until eof(input) or t.found;

   if eof(input) then begin
      writeln(output,'NO-VERSION-FOUND');
      halt;
   end;

   if t.found then begin
      capture(input, theversion, input);
      writeln(output, theversion:4:2);
   end;

   resettrigger(anof);
   repeat
      testfortrigger(input^, anof);
      get(input);
   until eof(input) or anof.found;

   if eof(input) then begin
      writeln(output,'NO-FILE-NAME-FOUND');
      halt
   end;

   skipblanks(input); (* skip space *)

   (* write the file name out *)
   while (input^ <> ' ') and (not eoln(input)) do begin
      write(output,input^);
      get(input);
   end;
   writeln(output);

end;
(* end module vr.themain *)

begin
      themain;
1: end. (* vr *)