{*	COMPARE - Compare two text files and report their differences.
*
*	Copyright (C) 1977, 1978
*	James F. Miner
*	Social Science Research Facilities Center
*	University of Minnesota
*
*	General permission to make fair use in non-profit activities
*	of all or part of this material is granted provided that
*	this notice is given.  To obtain permission for other uses
*	and/or machine readable copies write to:
*
*		The Director
*		Social Science Research Facilities Center
*		25 Blegen Hall
*		269 19th Ave. So.
*		University of Minnesota
*		Minneapolis, Minnesota  55455
*		U S A
}
 
{*	Compare is used to display on "Output" the differences
*	between two similar texts ("Filea" and "Fileb"). Notable
*	characteristics are:
*
*	- Compare is line oriented. The smallest unit of comparison
*	  is the text line (ignoring trailing blanks).  The present
*	  implementation has a fixed maximum line length.
*
*	- By manipulating a program parameter, the user can affect
*	  Compare's sensitivity to the "locality" of differences.
*	  More specifically this parameter, "Minlinesformatch",
*	  specifies the number of consecutive lines on each file
*	  which must match in order that they be considered as
*	  terminating the prior mismatch.  A large value of
*	  "Minlinesformatch" tends to produce fewer but larger
*	  mismatches than does a small value.  The value six appears
*	  to give good results on Pascal source files but may be
*	  inappropriate for other applications.
*
*	  If compare is to be used as a general utility program,
*	  "Minlinesformatch" should be treated as a program
*	  parameter of some sort.  It is declared as a constant here
*	  for portability's sake.
*
*	- Compare employs a simple backtracking search algorithm to
*	  isolate mismatches from their surrounding matches.  This
*	  requires (heap) storage roughly  proportional to the size
*	  of the largest mismatch, and time roughly proportional to
*	  the square of the size of the mismatch for each mismatch.
*	  For this reason it may not be feasible to use Compare on
*	  files with very long mismatches.
*
*	- To the best of the author's knowledge, Compare utilizes
*	  only features of Standard Pascal.
*
*	Compare was originally published in "Pascal News",
*	Number 12, June 1978 by James Miner.  See future
*	issues of "Pascal News" for possible updates to
*	this program.
*
*	Modified for NBS Pascal by:
*	James L. Agin  -  25 November 1978
*	TRW DSSG
*	90 / 2824
*	One Space Park
*	Redondo Beach, CA 90278
*
*	Modified 19-Oct-83 by Paul Lustgraaf for RT-11
}
program srccom(input,output,filea,fileb,outfile);
const
  version = '1  (19-Oct-83)';
  linelength = 120;			{max input linelength}
  defaultminlines = 3;		{default value of parameter}
 
type
  linepointer = @line;
  line = {packed} record
    nextline: linepointer;
    length: 0..linelength;
    image: {packed} array [1..linelength] of char;
  end;
 
  stream = record
    cursor, head, tail: linepointer;
    cursorlineno, headlineno, taillineno: integer;
    endfile: boolean;
  end;
  filenametype = array [1..20] of char;
 
var
  filea, fileb, outfile: text;
  FileAName,FileBName: filenametype;
  a, b: stream;
  match: boolean;
  endfile: boolean;	{ set if end stream a or b }
 
  templine: record	{ used by readline }
    length: integer;
    image: array [0..linelength] of char;
  end;
 
  freelines: linepointer;	{ free list of line buffer }	
  same: boolean;		{ false if no mis-match occur }
  report: boolean;		{ report/modify option flag }
  minlinesformatch: integer;	{ parameter }
 
procedure ReadFileName(var filename : filenametype);
var i : integer;
begin
  i := 1;
  while (not eoln(input)) and (i <= 20) do begin
    read(filename[i]);
    i := i+1;
  end;
  for i:=i to 20 do filename[i] := ' ';
  readln;
end; {ReadFileName}

procedure writeline;
begin
  writeln;
  if report then writeln(outfile);
end; {writeline}

procedure writestarline(n : integer);
var i : integer;
begin
  for i := 1 to n do begin
    write('*');
    if report then write(outfile,'*');
  end; {for}
  writeline;
end; {writestarline}

procedure comparefiles;
 
function endstream(var x: stream): boolean;
begin  { endstream }
  endstream := (x.cursor = nil) and x.endfile;
end;   { endstream }
 
procedure markcmp(var x: stream);
{ causes beginning of stream to be positioned before current
  sream cursor. buffers get reclaimed, line counters reset, etc. }
var p: linepointer;
begin  { markcmp }
  with x do
  if head <> nil then begin
    while head <> cursor do begin{ reclaim buffers }
      with head@ do begin
        p := nextline;
        nextline := freelines;
        freelines := head;
      end; {with}
      head := p;
    end; {while}
    headlineno := cursorlineno;
    if cursor = nil then begin 
      tail := nil;
      taillineno := cursorlineno;
    end;
  end;
end;  { markcmp }
 
procedure movecursor(var x: stream; var filex: text);
{ filex is the input file associated with x. the cursor for
  x is moved forward one line, reading from x if
  necessary, and incrementing the line count. endfile is set
  if eof is encountered on either stream. }
 
procedure readline;
var 
  newline: linepointer;
  c, c2: 0..linelength;
begin { readline }
  if not x.endfile then begin
    c := 0;
    while (not eoln(filex)) and (c < linelength) do begin
      c := c + 1; templine.image[c] := filex@;
      get(filex);
    end; {while}
    readln(filex);
    while templine.image[c] = ' ' do c := c - 1;
    if c < templine.length then
      for c2 := c + 1 to templine.length do templine.image[c2] := ' ';
    templine.length := c;
    newline := freelines;
    if newline = nil then new(newline) 
    else freelines := freelines@.nextline;
{** pack(templine.image,1,newline@.image); **}
    for c2 := 1 to c do	newline@.image[c2] := templine.image[c2];
    newline@.length := c;
    newline@.nextline := nil;
    if x.tail = nil then begin
      x.head := newline;
      x.taillineno := 1; x.headlineno :=1;
    end
    else begin
      x.tail@.nextline := newline;
      x.taillineno := x.taillineno + 1;
    end;
    x.tail := newline;
    x.endfile := eof(filex);
  end;
end;  {  readline  }
 
begin { movecursor }
  if x.cursor <> nil then begin
    if x.cursor = x.tail then readline;
    x.cursor := x.cursor@.nextline;
    if x.cursor = nil then endfile := true;
    x.cursorlineno := x.cursorlineno + 1;
  end
  else if not x.endfile then begin { beginning of stream }
    readline; x.cursor := x.head;
    x.cursorlineno := x.headlineno;
  end
  else endfile := true;
end;  { movecursor }
 
procedure backtrack(var x: stream; var xlines: integer);
{ causes the current position of stream x to become
  that of the last mark operation. xlines is set to
  the number of lines from the new cursor to the 
  old cursor, inclusive }
begin { backtrack }
  xlines := x.cursorlineno + 1 - x.headlineno;
  x.cursor := x.head; x.cursorlineno := x.headlineno;
  endfile := endstream(a) or endstream(b);
end;  { backtrack }
 
procedure comparelines(var match: boolean);
{ Compare the current lines of streams a and b, returning }
{ match to signal their (non-) equivalence.  Eof on both streams }
{ is considered a match, but eof on only one stream is a mismatch. }
begin
  if (a.cursor = nil) or (b.cursor = nil)
  then match := endstream(a) and endstream(b)
  else begin
    match := (a.cursor@.length = b.cursor@.length);
    if match then match := (a.cursor@.image = b.cursor@.image);
  end;
end; { comparelines }
 
procedure findmismatch;
begin { findmismatch }
  { not endfile and match }
  repeat  { compare nextlines }
    movecursor(a, filea); movecursor(b, fileb);
    markcmp(a); markcmp(b);
    comparelines(match);
  until (endfile) or (not match);
end; { findmismatch }
 
procedure findmatch;
var advanceb: boolean; { toggle one line lookahead between streams }
 
procedure search(var x: stream; { to search }
                 var filex: text;
                 var y: stream; { to lookahead }
                 var filey: text);
{ look ahead one line on stream y, and search for that line
  backtracking on stream x. }
var count: integer; { number lines backtracked on x }
 
procedure checkfullmatch;
{ from the current positions in x and y, which match,
  make sure that the next minlinesformatch - 1 lines also
  match, or else match := false }
var
  n: integer;
  savexcur, saveycur: linepointer;
  savexline, saveyline: integer;
begin { checkfullmatch }
  savexcur := x.cursor; saveycur := y.cursor;
  savexline := x.cursorlineno; saveyline := y.cursorlineno;
  comparelines(match);
  n := minlinesformatch - 1;
  while match and (n<>0) do begin
    movecursor(x,filex); movecursor(y, filey);
    comparelines(match); n := pred(n);
  end;
  x.cursor := savexcur; x.cursorlineno := savexline;
  y.cursor := saveycur; y.cursorlineno := saveyline;
end; { checkfullmatch }
 
begin { search }
  movecursor(y, filey); backtrack(x, count);
  checkfullmatch; count := pred(count);
  while (count <> 0) and not match do begin
    movecursor(x, filex); count := pred(count);
    checkfullmatch;
  end;
end; { search }
 
procedure printmismatch;
 
procedure writetext(p, q: linepointer);
begin { writetext }
  while (p<>nil) and (p <> q) do begin
    if p@.length <> 0 then begin
      write(p@.image: p@.length);
      if report then write(outfile,p@.image: p@.length);
    end; {if}
    writeline;
    p := p@.nextline;
  end;
  if (p = nil) then begin
    writeln('*** eof ***');
    if report then writeln(outfile,'*** eof ***');
  end;
end;  { writetext }
 
begin {printmismatch }
  writestarline(10);
  writetext(a.head, a.cursor);
  writestarline(4);
  writetext(b.head, b.cursor);
end; { printmismatch }
 
begin { findmatch }
  { not match }
  advanceb := true;
  repeat
    if not endfile then advanceb := not advanceb
    else advanceb := endstream(a);
    if advanceb then search(a, filea, b, fileb)
    else search(b, fileb, a, filea);
  until match;
  printmismatch;
end; { findmatch }
 
begin { comparefiles }
  match := true; { beginning of files match }
  repeat
    if match then findmismatch 
    else begin
      same := false; findmatch;
    end;
  until endfile and match;
end; { comparefiles }
 
procedure initialize;

procedure initstream(var x: stream; var filex: text);
begin { initstream }
  with x do begin
    cursor := nil; head := nil; tail := nil;
    cursorlineno := 0; headlineno := 0; taillineno := 0;
  end;
  x.endfile := eof(filex);
end; { initstream }
 
procedure options;
var ch: char;
    i: integer;
begin {options}
  report := false;
  writeln('Do you wish to print the differences? ');
  readln(ch);
  if (ch = 'Y') or (ch = 'y') then begin
    report := true;
    rewrite(outfile,"LP:SRCCOM.LST", 2);
    writeln(outfile,'Differences between ',FileAName,' and ',FileBName);
  end; {if}
  writeln('Enter number of lines that must be the same for a match: ');
  readln(minlinesformatch);
  if minlinesformatch < 1 then minlinesformatch := defaultminlines;
end; {options}
 
begin { initialize }
  write('Enter name of file A: ');
  ReadFileName(FileAName);
  reset(filea,FileAName,2);
  write('Enter name of file B: ');
  ReadFileName(FileBName);
  reset(fileb,FileBName,2);
  initstream(a, filea);
  initstream(b, fileb);
  options;
  endfile := a.endfile or b.endfile;
  freelines := nil;
  templine.length := linelength;
  templine.image[0] := 'x'; { sentinel }
end; { initialize }
 
begin {main}
  writeln('SRCCOM version ', version);
  initialize;
  writeln('Match criterion = ', minlinesformatch:1,' lines.');
  if report then
    writeln(outfile,'Match criterion = ', minlinesformatch:1,' lines.');
  if a.endfile then writeln('File A is empty.');
  if b.endfile then writeln('File B is empty.');
  if not endfile then begin
    same := true;
    comparefiles;
    if same then begin
      writeln('No differences.');
      if report then writeln(outfile,'No differences.');
    end {if}
    else begin
      writestarline(10);
      writeln('Files are different.');
    end; {else}
  end; {if}
end.