program main;


const HTSiz = 1296;
      MaxSym = 2000;
      MaxSymLen = 30;
      MaxFld = 10;

type StrTyp = string[100];
     lptr = ^longint;
     bptr = ^byte;
     byte = -128..127;
     FldTyp = packed record
                Bkt:integer;
                Slot: -32768..32767;
              end;
     tuple = array[1..MaxFld] of FldTyp;

var A: array [0..MaxSym] of packed record
         Fld: FldTyp;
       end;
    DB: array [1..2000] of tuple;
    seed,Xch,Cmp, Cmp1, Cmp2, Cmp3: longint;
    Siz,Bndry: integer;
    PagBuf: array [0..1024] of byte;
    PagPtr: record case integer of 0:(B:^Byte); 1:(A:longint); end;
    HTab : array [0..HTSiz] of integer;
    i: integer;
    NumTup: integer;
    ChrMap2,ChrMap1,ChrMap0: array[' '..'~'] of longint;
    DBFid: file;
    EndOfItem: boolean;
    SymFre: integer;
    Sum: real;
    Rng: array[0..10] of longint;
    CurFld: integer;
    SymTab : array [0..MaxSym] of record
                Key: string[MaxSymLen];
                Lnk: integer;
             end;

{
.PG
}
function LookUp( var ID: StrTyp ): integer;
var H, P, Q: integer;
    K: longint;
begin
   case length(ID) of
      0: K := 0;
      1: K := ChrMap2[ID[1]];
      2: K := ChrMap2[ID[1]] + ChrMap1[ID[2]];
      otherwise: begin
         K := ChrMap2[ID[1]] + ChrMap1[ID[2]] + ChrMap0[ID[3]];
      end;
   end;
   H := K mod HTSiz;
   P := H;
   Q := HTab[H];
   while (Q<>0) and (SymTab[Q].Key<>ID) do begin
      P := Q;
      Q := SymTab[Q].Lnk;
   end;

   if Q=0 then begin
      Q := SymFre;

      with SymTab[SymFre] do begin
         Key := ID;
         Lnk := 0;
      end;

      if P=H then begin
         HTab[H] := SymFre;
      end else begin
         SymTab[P].Lnk := SymFre;
      end;

      if SymFre<MaxSym then begin
         SymFre := SymFre + 1;
      end else begin
         writeln( '*** Symbol table overflow.' );
      end;

      Siz := Siz + 1;
      with A[Siz] do begin
         Fld.Bkt := K - 32768;
         Fld.Slot := Q;
      end;
   end;

   with DB[NumTup+1][CurFld] do begin
     Bkt := K - 32768;
     Slot := Q;
   end;
   if EndOfItem then begin
     NumTup := NumTup + 1;
     EndOfItem := false;
     CurFld :=  1;
   end else begin
     CurFld := CurFld + 1;
   end;
   LookUp := Q;
end;

{
.PG
}
function GetChr( var C: char ): boolean;
begin
  GetChr := true;
  if PagPtr.B^=0 then begin
    write( '.' );
    if blockread( DBFid, PagBuf, 2 )<>2 then begin
      fillchar( PagBuf, sizeof(PagBuf), chr(0) );
      GetChr := false;
    end;
    PagPtr.B := @PagBuf[0];
  end;
  C := chr(PagPtr.B^);
  case C of
    '\D': C := ' ';
    '~' : begin EndOfItem := true; C := '|'; end;
    '\0': begin EndOfItem := true; C := '|'; end;
    ',' : C := '|';

    'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k',
    'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v',
    'w', 'x', 'y',
    'z' : C := chr( PagPtr.B^ - 32 );

    ' ' : begin
            while PagPtr.B^=ord(' ') do
              PagPtr.A := PagPtr.A + 1;
            PagPtr.A := PagPtr.A - 1;
          end;
  end;
  PagPtr.A := PagPtr.A + 1;
end;

{
.PG
}
function GetID( var ID: StrTyp ): boolean;
var C: char;
    Done: boolean;
    Len     : record case integer of
                0:(A:longint);
                1:(B:^byte);
              end;
begin
  repeat
    GetID := GetChr( C );
  until C<>' ';

  {$R-}
  Len.A := ord4(@ID);
  Len.B^ := 0;
  while C<>'|' do begin
    Len.B^ := Len.B^ + 1;
    ID[Len.B^] := C;
    GetID := GetChr( C );
  end;

  while ID[Len.B^]=' ' do Len.B^ := Len.B^ - 1;
  {$R+}

  if CurFld>MaxFld then EndOfItem := true;
  if Len.B^>MaxSymLen then Len.B^ := MaxSymLen;
  if Len.B^=0 then ID := ' ';
end;

{
.PG
}
procedure unique;
var ID: StrTyp;
    Dum: integer;
    Fnam: StrTyp;
begin
  if argc>0 then begin
    FNam := argv[1]^;
  end else begin
    write( 'Name of data base file? ' );
    readln( fnam );
  end;
  fnam := concat( fnam, '.text' );
  {$i-}
  reset( DBFid, fnam );
  if ioresult<>0 then reset( DBFid, concat( '/ccsys/', fnam ));
  if ioresult<>0 then reset( DBFid, concat( '/ccutil/', fnam ));
  if ioresult<>0 then begin
    writeln( 'Unable to find file "', Fnam,'"' );
    halt;
  end;
  {$i+}
  Dum := blockread( DBFid, PagBuf, 2 );

  while GetID( ID ) do begin
    Dum := LookUp( ID );
  end;
  close( DBFid );
end;

{
.PG
}
procedure init;
var i: longint;
    DBNam: StrTyp;
begin
  writeln( '\1BJ' );
  fillchar( HTab, sizeof(HTab), chr(0) );
  SymFre := 1;
  SymTab[0].Key := '';
  SymTab[0].Lnk := 0;
  NumTup := 0;
  fillchar( PagBuf, sizeof(PagBuf), chr(0) );
  fillchar( DB, sizeof(DB), chr(0) );
  PagPtr.B := @PagBuf[0];
  CurFld := 1;
  Siz := 0;
  EndOfItem := false;
  fillchar( ChrMap0, sizeof(ChrMap0), chr(0) );
  fillchar( ChrMap1, sizeof(ChrMap1), chr(0) );
  fillchar( ChrMap2, sizeof(ChrMap2), chr(0) );
  for i := 0 to 9 do begin
    ChrMap0[chr(i+ord('0'))] := i;
    ChrMap1[chr(i+ord('0'))] := i*36;
    ChrMap2[chr(i+ord('0'))] := i*1296;
  end;
  for i := 0 to 25 do begin
    ChrMap0[chr(i+ord('A'))] := i + 10;
    ChrMap1[chr(i+ord('A'))] := 36 * (i + 10);
    ChrMap2[chr(i+ord('A'))] := 1296 * (i + 10);
  end;
  Xch := 0;
  Cmp := 0;
  Cmp1 := 0;
  Cmp2 := 0;
  Cmp3 := 0;
  for i := 0 to 10 do Rng[i] := 0;
  writeln( 'Corvus Concept LOOKUP 1.0' );
  writeln;
end;

{
.PG
}
procedure dumparray;
var i: integer;
begin
  for i := 1 to siz do begin
    write( I:1 );
    write( A[i].Fld.Bkt:5 );
    write( A[i].Fld.Slot:5, ' ' );
    write( SymTab[A[i].Fld.Slot].Key );
    writeln;
    if unitbusy(1) then begin
      readln;
      exit(dumparray);
    end;
  end;
  writeln;
end;

{
.PG
}
procedure QuickSort( L, R: longint );
var i, j: integer;
    flip: boolean;
    x,y: record case integer of
          0:(a:longint);
          1:(b:^integer);
          2:(v:lptr);
          3:(d:^double);
        end;
    t: longint;
begin
  if L<R then begin
    x.a := L;
    y.a := R;
    flip := false;
    while x.a<y.a do begin
      Cmp := Cmp + 1;
      if x.b^>y.b^ then begin { COMPARE SHORT Bkt }
        flip := not flip;
        t := x.v^;
        x.v^ := y.v^;
        y.v^ := t;
      end else if x.b^=y.b^ then begin { EXTENDED COMPARE REQ'D }
        Cmp1 := Cmp1 + 1;
        if x.v^<>y.v^ then begin { DIFFERENT KEYS }
          { GOTO SYMTAB FOR COMPARE }
          Cmp3 := Cmp3 + 1;
          if SymTab[ x.v^ AND $FFFF ].Key >
             SymTab[y.v^ AND $FFFF].Key then begin
            flip := not flip;
            t := x.v^;
            x.v^ := y.v^;
            y.v^ := t;
          end;
        end else begin
          flip := not flip; { FORCE BETTER PARTITIONS }
        end;
      end;
      if flip then begin
        x.a := x.a + 4;
      end else begin
        y.a := y.a - 4;
      end;
    end;
    QuickSort( L, x.a-4 );
    QuickSort( x.a+4, R );
  end;
end;

{
.PG
}
procedure sortarray;
begin
  QuickSort( ord4(@A[1]), ord4(@A[Siz]) );
end;

{
.PG
}
procedure ShowTup( Tup: tuple );
var i: integer;
    S: StrTyp;
    L: integer;
begin
  write( '|' );
  i := 1;
  repeat
    S := SymTab[Tup[i].Slot].Key;
    L := length( SymTab[DB[2][i].Slot].Key );
    if L>0 then begin
      if length(S)>L then begin
        write( copy( S, 1, L ) );
      end else begin
        write( S, '':L-length(S) );
      end;
      write( '|' );
    end;
    i := i + 1;
  until (L=0) or (i>MaxFld);
  writeln;
end;

{
.PG
}
procedure Bar( Tup: tuple );
var i, j, L: integer;
begin
  write( '+----+' );
  i := 1;
  repeat
    L := length( SymTab[Tup[i].Slot].Key );
    if L>0 then begin
      for j := 1 to L do write( '-' );
      write( '+' );
    end;
    i := i + 1;
  until (L=0) or (i>MaxFld);
  writeln;
end;

{
.PG
}
procedure Search( Fld: FldTyp );
var Fnd: boolean;
    i,T,ITEM : integer;
    P: record case integer of
         0:( v:^longint);
         1:( a: longint);
       end;
    Q: longint;
begin
  Bar( DB[2] );
  write( '|ITEM' );
  ShowTup( DB[1] );
  Bar( DB[2] );
  moveleft( Fld, Q, 4 );
  P.a := ord4(@DB[3][1]);
  Item := 1;
  for T := 3 to NumTup do begin
    Fnd := false;
    for i := 1 to MaxFld do begin
      if P.v^=Q then Fnd := true;
      P.a := P.a + 4;
    end;
    if Fnd then begin
      write( '|', Item:3, ' ' );
      ShowTup( DB[T] );
      Item := Item + 1;
    end;
  end;
  Bar( DB[2] );
end;

{
.PG
}
procedure Query;
var Cmd: StrTyp;
    B: byte;
    i,j,Sel: longint;
    DumpIt: boolean;
begin
  writeln;
  writeln( 'File loaded.' );
  if argc=2 then begin
    Cmd := ArgV[2]^;
  end else begin
    writeln;
    write( 'Selection: \1Bc' );
    readln( Cmd );
  end;
  while Cmd<>'' do begin
    for i := 1 to length(Cmd) do
      if Cmd[i] in ['a'..'z'] then Cmd[i] := chr(ord(Cmd[i])-32);
    write( '\1BJ\1Bb' );
    j := 0;
    i := 1;
    while i<=Siz do begin
      if pos( Cmd, SymTab[A[i].Fld.Slot].Key )=1 then begin
        Sel := i;
        if j<40 then writeln( SymTab[A[i].Fld.Slot].Key );
        if Cmd=SymTab[A[i].Fld.Slot].Key then i := Siz;
        j := j + 1;
      end;
      i := i + 1;
    end;
    writeln;
    if j>1 then begin
      writeln( 'To which of the above does "', Cmd, '" refer?' );
    end else if j=0 then begin
      writeln( 'NO MATCH FOUND FOR "', CMD, '"' );
    end else begin
      Search(A[Sel].Fld);
    end;
    writeln;
    write( 'Selection: \1Bc' );
    readln( Cmd );
  end;
end;

{
.PG
}
procedure doit;
var i: integer;
begin
  unique;
  sortarray;
  Query;
end;


{
.PG
}
procedure wrapup;
begin
end;

begin
  init;
  doit;
  wrapup;
end.


