program ixmerge; {$I+,R-,A-,B-}
{==============================================================}
{		Book Indexing Assistant, merge utility	       }
{Copyright (C) 1986 David E. Cortesi--see notice in IXMAIN.PAS }
{							       }
{ This utility merges two index documents as prepared by the   }
{ IXMAIN program -- see it and INDEXER.DOC for further info.   }
{							       }
{ The essential insight that simplifies this program is that it}
{ doesn't have to make any provision for sub-indexes at any    }
{ level.  All it has to do is preserve the initial blanks that }
{ are used to indent subterms, and include them in comparisons.}
{ Then subterms always compare "less" versus their own (or any)}
{ superior terms.  Thus once a term-line in a file F has been  }
{ chosen for output because it is less than the current line of}
{ the other file, any subterms it may have will necessarily    }
{ compare less to the other file as well, and will follow their}
{ superior to the output automatically.  When two lines are    }
{ equal both files are advanced and, if both files had subterms}
{ for that term, they will be compared and merged.  If only one}
{ file had subterms for that term, they'll all compare "less"  }
{ to the unindented next line of the other file as before.     }
{							       }
{ History:						       }
{ insert traps against endless loop & simplify mergem()11/20/86}
{ fix bug in pagemrg() 11/20/86 			       }
{ fix pointer-initialization bugs 11/5/86		       }
{ comments and minor cleanup 11/4/86			       }
{ initial writing 11/3/86				       }
{==============================================================}

const
    null = 0;		{ the null, end-of-string	       }
    asciibel = 7;	{ names for ascii characters	       }
    asciitab = 9;
    asciicr = 13;
    asciieof = 26;
    asciiblank = 32;
    asciidel = 127;
    allowset : set of char = ['a'..'z'];
    digitset : set of char = ['0'..'9'];

    maxnests = 9;	{ allows up to 9 levels of subterms }
    strmax = 65;	{ max size of a string, 64 data plus 00}
    trmmax = 99; {at least strmax+3*maxnests to allow for
		  the indentation spaces, which are retained }
    maxpages = 99;	{ most page number (ranges) per term }

type
    relation = (less,equal,more); { result of comparisons      }
    nchar = 0..255;		{ numeric characters are bytes }
    trmindex = 1..trmmax;	{ indices over strings	       }
    trmcount = 0..trmmax;	{ lengths of strings	       }
    trm = packed array[trmindex] of nchar; { term as string}

    pagindex = 1..maxpages;	{ indices over page numbers    }
    pagcount = 0..maxpages;	{ counts of page numbers       }
    pages = record		{ a record of a term's pages   }
	np : pagcount;
	p1,p2 : array[pagindex] of integer;
    end;
    pageptr = ^pages;		{ pointer to one of those }

    line = record		{ record of one file line }
	t,u : trm;	{ term as given and uppercase }
	p : pageptr;	{ ^list of page numbers }
    end;
    lineptr = ^line;
    filespec = string[127];
    filer = record	{ info about one textfile }
	pf : ^text;	{ address of file }
	pushed : nchar; { pushed-back byte }
	lineno, 	{ line number for diagnostics }
	column, 	{ logical column in line }
	blanks : integer; { blanks owed for last tab seen }
	fn : filespec;
    end;

var
    lineA, lineB : lineptr;
    pageA, pageB, pageM : pageptr;
    finA, finB, fout : text; { two infiles and an out }
    frA, frB: filer; {two infiles with associated vars }
    initial : nchar; {control-break during output }

{------ open an input file, return true if any problems ------}
function initinp(var f:text; fs:filespec; var fr: filer):
						 boolean;
begin {$I- check own I/O results }
    assign(f,fs);
    reset(f);
    if (0 = IOresult) then initinp := eof(f)
    else initinp := true;
    with fr do begin
	pf := Ptr(Addr(f));
	pushed := null;
	lineno := 0;
	column := 0;
	blanks := 0;
	fn := fs;
    end
end; {$I+ back to compiler checks on I/O }

{------ push back one byte of input, and damn Borland for -----}
{------ making this necessary by leaving out get/put i/o ------}
procedure pushbak(n:nchar; var f:filer);
begin f.pushed := n end;

{------ return the next byte from the text file inpfile -------}
function nextinp(var f: filer) : nchar;
var c : char; n : nchar;
begin
    with f do begin
	if (pushed <> null) then begin
	    n := pushed;
	    pushed := null
	end
	else if eof(pf^) then n := asciieof
	else if eoln(pf^) then begin
	    readln(pf^);
	    n := asciicr;
	    column := 0;
	    blanks := 0
	end
	else if (blanks > 0) then begin
	    n := asciiblank;
	    blanks := blanks - 1;
	end
	else begin
	    read(pf^,c);
	    n := ord(c);
	    if (n <> asciitab) then
		column := column + 1
	    else begin
		blanks := 7 - (column mod 8);
		column := column + blanks;
		n := asciiblank
	    end
	end
    end; {with}
    nextinp := n
end;

{------ open the output file ----------------------------------}
procedure initout;
begin
    assign(fout,'INDEX.OUT');
    rewrite(fout);
    initial := null;
end;

{------ write a byte to the output - this is ONLY output ------}
procedure nextout(n:nchar);
begin
    if	    (n = asciicr) then writeln(fout)
    else if (n = asciieof) then close(fout)
    else write(fout,chr(n))
end;

{------ diagnose an error in the input file and abort ---------}
procedure badfile(e:integer; var f: filer);
begin
    writeln;
    writeln('Error in line ',f.lineno:1,' of file ',f.fn);
    write('...');
    case e of
	1 : write('term must shorter than ',trmmax,' letters');
	2 : write('term must be printable characters');
	3 : write('found nondigit where number expected');
	4 : write('page number too large');
	5 : write('improper range of numbers');
	6 : write('too many page numbers');
	7 : write('reading past eof (logic error)');
    end;
    writeln('... output file may be incomplete.');
    nextout(asciieof); { close output file }
    writeln;
    HALT
end;

{------ write an integer without a leading blank --------------}
procedure intwrite(x : integer);
const
    czero = 48;
    powten : array[1..4] of integer = (10,100,1000,10000);
var
    k, p : integer;
    d : nchar;
    z : boolean;
begin
    if (x < 0) then begin
	nextout(ord('-'));
	x := abs(x)
    end;
    z := false;
    { n.b. integer division is VERY slow in 8-bit turbo }
    { yes, slower than 5 adds and 5 subtracts }
    for k := 4 downto 1 do begin
	p := powten[k];
	d := czero;
	while (x > 0) do begin
	    d := d + 1;
	    x := x - p
	end;
	if (x < 0) then begin
	    x := x + p;
	    d := d - 1
	end;
	if (d > czero) then z := true;
	if (z) then nextout(d)
    end;
    nextout(czero+x)
end;

{---- write the contents of one line to the output file, ------}
{---- first the term and then the list of numbers if any. -----}
{---- Insert a null line if this is a change of initials at ---}
{---- the left margin. ----------------------------------------}
procedure putline(var l:line; var f:filer);
var j : trmindex; n : pagcount;
begin
    if (l.t[1] = asciidel) then badfile(7,f);
    if (l.t[1] <> asciiblank) then { chk only at level 0 }
	if (l.t[1] <> initial) then begin { is control brk }
	    if (initial <> null) then { isn't first time }
		nextout(asciicr);
	    initial := l.t[1]
	end;
    j := 1;
    repeat
	nextout(l.t[j]);
	j := j+1
    until ((l.t[j] = null) or (j = trmmax));
    if (l.p^.np <> 0) then
	with l.p^ do begin
	    nextout(ord(','));
	    nextout(asciiblank);
	    nextout(asciiblank);
	    for n := 1 to np do begin
		if (n > 1) then begin
		    nextout(ord(','));
		    nextout(asciiblank)
		end;
		intwrite(p1[n]);
		if (p2[n] > p1[n]) then begin
		    nextout(ord('-'));
		    intwrite(p2[n])
		end
	    end {for}
	end; {with}
    nextout(asciicr)
end;

{--- compare two terms returning less, equal, or more -------}
function trmcomp(var ta,tb: trm) : relation;
var j : trmcount; a,b : nchar;
begin
    j := 0;
    repeat
	j := j+1;
	a := ta[j];
	b := tb[j]
    until ((a <> b) or (a = null));
    if	    (a < b) then trmcomp := less
    else if (a > b) then trmcomp := more
    else		 trmcomp := equal
end;

{--- return uppercase form of a letter ------------------------}
function upcase(n:nchar):nchar;
begin
    if (chr(n) in allowset) then
	upcase := n-32
    else
	upcase := n
end;

{------ read and collect one signed integer, assuming that ----}
{------ there should be a number coming next from nextinch ----}
function getpage(var f: filer):integer;
var n : nchar; s : boolean; x : real;
begin
    n := nextinp(f);
    s := n = ord('-');
    if (s) then n := nextinp(f);
    if (not (chr(n) in digitset)) then badfile(3,f);
    x := 0.0;
    repeat
	x := (x * 10.0) + (n - ord('0'));
	n := nextinp(f);
    until (not (chr(n) in digitset));
    pushbak(n,f);
    if (x > 32767.0) then badfile(4,f);
    if (s) then x := -x;
    getpage := trunc(x)
end;

{--- get a line of text from the given index document and -----}
{--- separate it into a term-string and series of binary ------}
{--- page numbers.  store the term in lowercase and uppercase -}
{--- forms for quick comparisons.  Store eof as a "term" of ---}
{--- asciidel so as to compare high to all legitimate terms ---}
procedure getline(var f: filer; var l:line);
var j: trmcount; k:pagcount; n: nchar; i : integer;
begin
    if (l.u[1] = asciidel) then badfile(7,f);
    repeat
	{ read and skip null lines. stop on nonnull term or eof }
	f.lineno := f.lineno + 1;
	j := 0;
	repeat
	    {read and store initial blanks up to term, cr, or eof}
	    n := nextinp(f);
	    if (n = asciiblank) then begin
		j := j+1;
		l.u[j] := n;
		l.t[j] := n
	    end
	until ((n <> asciiblank) or (j = trmmax));
	if (j = trmmax) then badfile(1,f);
	{ here n is either cr, eof, or a graphic }
    until (n <> asciicr); { loop on n=cr case }
    { here n is either eof or a graphic }
    if (n = asciieof) then begin { create 'infinity' at eof}
	for j := 1 to trmmax-1 do begin
	    l.t[j] := asciidel;
	    l.u[j] := asciidel
	end;
	l.t[trmmax] := null;
	l.u[trmmax] := null
    end
    else begin
	{ n contains first byte of term, j is count of blanks }
	repeat
	    j := j+1;
	    l.t[j] := n;
	    l.u[j] := upcase(n);
	    n := nextinp(f)
	until ( ((n = asciiblank) and (l.t[j] = asciiblank)) or
		(n < asciiblank) or
		(j = trmmax));
	if ((n <> asciiblank) and (n <> asciicr)) then
	    badfile(2,f); { unknown control character }
	if ((j = trmmax) and (n <> asciiblank)) then
	    badfile(1,f); { line too long }
	if (n = asciicr) then j := j+1;
	if (l.t[j-1] = ord(',')) then j := j-1;
	l.t[j] := null; {terminate the terms}
	l.u[j] := null;
	with l.p^ do begin
	    np := 0;
	    k := 1;
	    while (n = asciiblank) do n := nextinp(f);
	    while (n <> asciicr) do begin
		{ n is neither blank nor cr, s.b. digit }
		pushbak(n,f); { put it back for getpage }
		i := getpage(f);
		p1[k] := i;
		n := nextinp(f);
		if (n = ord('-')) then begin
		    i := getpage(f);
		    if (i <= p1[k]) then badfile(5,f);
		    n := nextinp(f)
		end;
		p2[k] := i;
		{ n = byte after last digit: cr, comma, or blank }
		while ( (n = asciiblank) or (n = ord(',')) ) do
		    n := nextinp(f);
		k := k + 1;
		if (k = maxpages) then badfile(6,f)
	    end;
	    np := k - 1
	end {with}
    end { else not end of file }
end;

{--- merge two arrays of page numbers to make a third, allowing }
{--- for ranges of page numbers. -------------------------------}
procedure pagemrg(var a,b,m: pages);
var i,j,k :pagcount;
begin
     i := 1; j := 1; k := 1;
     while ( (i <= a.np) and (j <= b.np) ) do begin
	 if (a.p1[i] <= b.p1[j]) then begin
	    m.p1[k] := a.p1[i];
	    if (a.p2[i] < b.p1[j]) then {a less & disjoint}
		m.p2[k] := a.p2[i]
	    else begin { a less or equal but not disjoint }
		if (a.p2[i] < b.p2[j]) then
		    m.p2[k] := b.p2[j]
		else
		    m.p2[k] := a.p2[i];
		j := j+1
	    end;
	    i := i + 1
	end
	else begin { b.p1 < a.p1 }
	    m.p1[k] := b.p1[j];
	    if (b.p2[j] < a.p1[i]) then { b less & disjoint}
		m.p2[k] := b.p2[j]
	    else begin { b less but not disjoint }
		if (b.p2[j] < a.p2[i]) then
		    m.p2[k] := a.p2[i]
		else
		    m.p2[k] := b.p2[j];
		i := i + 1
	    end;
	    j := j + 1
	end;
	k := k + 1
    end;
    while (i <= a.np) do begin
	m.p1[k] := a.p1[i];
	m.p2[k] := a.p2[i];
	k := k + 1;
	i := i + 1
    end;
    while (j <= b.np) do begin
	m.p1[k] := b.p1[j];
	m.p2[k] := b.p2[j];
	k := k + 1;
	j := j + 1
    end;
    m.np := k-1;
end;

{-- merge the two input files to the output file --------------}
procedure mergem;
var r: relation;
begin
    getline(frA,lineA^);
    getline(frB,lineB^);
    while ((lineA^.t[1] < asciidel)
       and (lineB^.t[1] < asciidel)) do begin
	r := trmcomp(lineA^.u,lineB^.u);
	case r of
	    less: begin
		putline(lineA^,frA);
		getline(frA,lineA^)
		end;
	    equal: begin
		pagemrg(lineA^.p^,lineB^.p^,pageM^);
		lineA^.p := pageM;
		putline(lineA^,frA);
		lineA^.p := pageA;
		getline(frA,lineA^);
		getline(frB,lineB^)
		end;
	    more: begin
		putline(lineB^,frB);
		getline(frB,lineB^)
		end
	end {case}
    end {while};
    while (lineA^.t[1] < asciidel) do begin
	putline(lineA^,frA);
	getline(frA,lineA^)
    end;
    while (lineB^.t[1] < asciidel) do begin
	putline(lineB^,frB);
	getline(frB,lineB^)
    end
end;

{==============================================================}
{ The main program, at last.....			       }
{==============================================================}
begin
    writeln('[index document merge, version of 11/20/86]');
    writeln('[copyright (c) 1986 David E. Cortesi]');
    if (Paramcount <> 1) then begin
     writeln('Command form is: IXMERGE addfilename');
     writeln('Document "addfilename" is merged with INDEX.INP');
     writeln('to form combined file INDEX.OUT.');
	Halt
    end;
    if (initinp(finA,'INDEX.INP',frA)) then begin
	writeln('file INDEX.INP doesn''t exist or is empty.');
	Halt
    end;
    if (initinp(finB,ParamStr(1),frB)) then begin
	writeln('file ',ParamStr(1),
		' doesn''t exist or is empty.');
	Halt
    end;
    initout;
    new(lineA); new(lineB);
    new(pageA); new(pageB); new(pageM);
    lineA^.p := pageA; lineB^.p := pageB;
    lineA^.u[1] := null; lineB^.u[1] := null;
    mergem;
    nextout(asciieof); {close output file}
end.

