ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[VS2000.PAS]ÄÄÄ
program VirSort_2000_for_29A_issue_5;

uses
     dos, crt, lgarray;

var
   f         : text;
   newfile   : text;
   flag1     : boolean;
   flag2     : boolean;
   count     : longint;
   log_file  : string;
   tipo      : string;
   dic1      : dictionary;
   dic2      : dictionary;
   dic3      : dictionary;
   dic4      : dictionary;
   dic5      : dictionary;
   dic6      : dictionary;
   dic7      : dictionary;
   dic8      : dictionary;
   dic9      : dictionary;
   dic10     : dictionary;
   dic11     : dictionary;
   dic12     : dictionary;
   dic13     : dictionary;
   i         : integer;
   log       : text;
   instring  : string;
   filename  : string;
   virusname : string;
   test      : longint;
   parm1     : string;
   parm2     : string;
   parm3     : string;
   last_bar  : byte;
   tmp_str   : string;
   TBuff     : Pointer;
   TBuffsize : LongInt;
   temp_string      : string;
   space_position   : byte;

procedure ShowHelp;
begin
     writeln('   -b {s}              <logname>            Build new DAT file');
     writeln('   -c {s}              <logname>            Compare someone elses log');
     writeln('   -a {l} {s}          <logname>            Add new virii');
     writeln('   -h {u}                                   Count virii');
     writeln;
     halt;
end;

procedure call_buffer;
begin
tbuffsize:=Maxavail;
if tbuffsize > $fff0 then tbuffsize := $fff0;
getmem(tbuff,tbuffsize);
end;

procedure inicializa_diccionarios;
begin
     dicAssign(dic1,'dict1');
     dicRewrite(dic1,4000);
     dicAssign(dic2,'dict2');
     dicRewrite(dic2,4000);
     dicAssign(dic3,'dict3');
     dicRewrite(dic3,4000);
     dicAssign(dic4,'dict4');
     dicRewrite(dic4,4000);
     dicAssign(dic5,'dict5');
     dicRewrite(dic5,5000);
     dicAssign(dic6,'dict6');
     dicRewrite(dic6,5000);
     dicAssign(dic7,'dict7');
     dicRewrite(dic7,4000);
     dicAssign(dic8,'dict8');
     dicRewrite(dic8,4000);
     dicAssign(dic9,'dict9');
     dicRewrite(dic9,4000);
     dicAssign(dic10,'dict10');
     dicRewrite(dic10,4000);
     dicAssign(dic11,'dict11');
     dicRewrite(dic11,4000);
     dicAssign(dic12,'dict12');
     dicRewrite(dic12,4000);
     dicAssign(dic13,'dict13');
     dicRewrite(dic13,4000);
end;

procedure escribe_diccionario;
begin
if UpCase(virusname[1]) >= 'T' then
                                   begin
                                   if UpCase(virusname[1]) <= 'U' then dicWrite(dic8,virusname,test)
                                   else if UpCase(virusname[1]) = 'V' then dicWrite(dic9,virusname,test)
                                   else if UpCase(virusname[1]) = 'W' then dicWrite(dic6,virusname,test)
                                   else if UpCase(virusname[1]) <= 'Z' then dicWrite(dic10,virusname,test)
                                   else dicWrite(dic1,virusname,test);
                                   end
else if UpCase(virusname[1]) >= 'M' then
                                        begin
                                        if UpCase(virusname[1]) = 'M' then dicWrite(dic13,virusname,test)
                                        else if UpCase(virusname[1]) <= 'O' then dicWrite(dic4,virusname,test)
                                        else if UpCase(virusname[1]) <= 'Q' then dicWrite(dic5,virusname,test)
                                        else if UpCase(virusname[1]) <= 'S' then dicWrite(dic7,virusname,test);
                                        end
else
    begin
    if UpCase(virusname[1]) <= 'B' then dicWrite(dic1,virusname,test)
    else if UpCase(virusname[1]) <= 'F' then dicWrite(dic2,virusname,test)
    else if UpCase(virusname[1]) <= 'H' then dicWrite(dic3,virusname,test)
    else if UpCase(virusname[1]) <= 'J' then dicWrite(dic11,virusname,test)
    else if UpCase(virusname[1]) <= 'L' then dicWrite(dic12,virusname,test);
    end;
end;

procedure cierra_diccionarios;
begin
     dicClose;
     dicErase(dic1);
     dicErase(dic2);
     dicErase(dic3);
     dicErase(dic4);
     dicErase(dic5);
     dicErase(dic6);
     dicErase(dic7);
     dicErase(dic8);
     dicErase(dic9);
     dicErase(dic10);
     dicErase(dic11);
     dicErase(dic12);
     dicErase(dic13);
end;

procedure no_virii;
begin
writeln('No virii found to process!');
end;

procedure no_new_virii_found;
begin
writeln('No new virii found');
end;

procedure no_new_virii_added;
begin
writeln('No new virii added');
end;

procedure not_find_avp;
begin
writeln('Can not find AVP.DAT in current directory!');
end;

procedure not_find_fprot;
begin
writeln('Can not find FPROT.DAT in current directory!');
end;

procedure no_dat;
begin
writeln('No DAT files found!');
end;

procedure longitud(log_file : string);
var
   f            : file of Byte;
   size         : Longint;

begin
     assign(f,log_file);
     reset(f);
     size := filesize(f);
     close(f);
     if size = 0 then erase(f);
end;

procedure OpenLog(logname : string);
begin
     assign(log,logname);
     call_buffer;
     settextbuf(log,tbuff^,tbuffsize);
     {$I-}
     reset(log);
     {$I+}
     flag2:=false;
     if IOResult <> 0 then flag2 := true;
end;

procedure DetectLog;
begin
     flag1:=false;
     tipo:='';
     while flag1=false do
     begin
     readln(log,instring);
     if (pos('infected:',instring)) or (pos('warning:',instring)) > 0 then
     begin
     tipo:='AVP';
     flag1:=true;
     end
     else if pos(' Infection: ',instring) > 0 then
     begin
     tipo:='F-PROT';
     flag1:=true;
     end;
     if eof(log) then flag1:=true;
     end;
end;

procedure BuildNewDat_A(logname:string);
begin
     writeln('Detected AVP log file');
     writeln('Building AVP.DAT from ',logname);
     reset(log);
     assign(f,'AVP.DAT');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     rewrite(f);

     inicializa_diccionarios;

     count := 0;

     repeat
           readln(log,instring);
                     flag1 := false;
                     filename := instring;
                     virusname := instring;
                     if pos('infected:',filename) > 0 then
                     begin
                     for last_bar:=length(filename) downto 0 do if filename[last_bar]=':' then break;
                     delete(filename,last_bar-9,length(filename));
                     delete(virusname,1,last_bar+1);
                     flag1 := true;
                     end
                     else if pos('warning:',filename) > 0 then
                     begin
                     for last_bar:=length(filename) downto 0 do if filename[last_bar]=':' then break;
                     delete(filename,last_bar-8,length(filename));
                     delete(virusname,1,last_bar+1);
                     virusname := virusname+'.warning';
                     flag1 := true;
                     end;
                     if flag1 = true then
                     begin
                     if pos(' ',virusname) >0 then
                                                  begin
                                                  tmp_str:=copy(virusname,1,pos(' ',virusname)-1);
                                                  delete(virusname,1,pos(' ',virusname));
                                                  virusname:=concat(tmp_str+'_'+virusname);
                                                  end;
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(f,filename,#1,virusname);
                     end;
                     end;
     until eof(log);
     writeln(count,' virii found for AVP...');

     Cierra_diccionarios;

     close(f);
     close(log);
     writeln;
end;

procedure BuildNewDAT_F(logname:string);
begin
     writeln('Detected F-Prot log file');
     writeln('Building FPROT.DAT from ',logname);
     reset(log);
     assign(f,'FPROT.DAT');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     rewrite(f);

     inicializa_diccionarios;

     count := 0;

     repeat
           readln(log,instring);
           space_position:=pos('ection: ',instring);
           if space_position > 0 then
                begin
                     filename := instring;
                     virusname := instring;
                     delete(filename,space_position-5,length(filename));
                     delete(virusname,1,space_position+7);
                     if pos('New or',virusname) > 0 then
                                                        begin
                                                        delete(virusname,1,pos('of ',virusname)+2);
                                                        virusname:=concat(virusname+'.variant');
                                                        end;
                     if (parm1 = '-BS') then
                     else if pos(' ',virusname) > 0 then delete(virusname,pos(' ',virusname),length(virusname));
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(f,filename,#1,virusname);
                     end;
                end;
     until eof(log);
     writeln(count,' virii found for F-Prot...');

     Cierra_diccionarios;

     close(f);
     close(log);
     writeln;
end;

procedure CompareDAT_A(logname:string);
begin
     writeln('Comparing virii from ',logname);
     writeln('Detected AVP log file');
     reset(log);

     inicializa_diccionarios;

     assign(f,'avp.dat');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     {$I-}
     reset(f);
     {$I+}
     if IOResult <> 0 then not_find_avp
     else
     begin
     repeat
           readln(f,virusname);
           delete(virusname,1,pos(#1,virusname));
           escribe_diccionario;
     until eof(f);
     close(f);

     tmp_str:=('NEWAVP.LOG');
     assign(newfile,'NEWAVP.LOG');
     call_buffer;
     settextbuf(newfile,tbuff^,tbuffsize);
     {$I-}
     reset(newfile);
     {$I+}
     count:=1;
     while IOResult = 0 do
     begin
         close(newfile);
         str(count,tmp_str);
         for i:=1 to 1-length(tmp_str) do tmp_str:=tmp_str;
         tmp_str:=concat('NEWAVP.LO'+tmp_str);
         inc(count);
         assign(newfile,tmp_str);
         call_buffer;
         settextbuf(newfile,tbuff^,tbuffsize);
         {$I-}
         reset(newfile);
         {$I+}
     end;

     rewrite(newfile);

     count := 0;
     log_file:=tmp_str;

     repeat
           readln(log,instring);
                     flag1 := false;
                     virusname := instring;
                     if pos('infected:',virusname) >0 then
                     begin
                     for last_bar:=length(virusname) downto 0 do if virusname[last_bar]=':' then break;
                     delete(virusname,1,last_bar+1);
                     flag1 := true;
                     end
                     else
                     begin
                     if pos('warning:',virusname) >0 then
                     begin
                          for last_bar:=length(virusname) downto 0 do if virusname[last_bar]=':' then break;
                          delete(virusname,1,last_bar+1);
                          virusname := virusname+'.warning';
                          flag1 := true;
                     end;
                     end;
                     if flag1 = true then
                     begin
                     if pos(' ',virusname) >0 then
                                                  begin
                                                  tmp_str:=copy(virusname,1,pos(' ',virusname)-1);
                                                  delete(virusname,1,pos(' ',virusname));
                                                  virusname:=concat(tmp_str+'_'+virusname);
                                                  end;
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(newfile,instring);
                     end;
                     end;
     until eof(log);
     if count=0 then no_new_virii_found
     else
         begin
         writeln(count,' new AVP virii found...');
         writeln;
         end;

     Cierra_diccionarios;

     close(newfile);
     close(log);

longitud(log_file);
end;
end;

procedure CompareDAT_F(logname:string);
begin
     writeln('Comparing virii from ',logname);
     writeln('Detected F-Prot log file');
     reset(log);

     inicializa_diccionarios;

     assign(f,'fprot.dat');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     {$I-}
     reset(f);
     {$I+}
     if IOResult <> 0 then not_find_fprot
     else
     begin
     repeat
           readln(f,virusname);
           delete(virusname,1,pos(#1,virusname));
           escribe_diccionario;
     until eof(f);
     close(f);

     tmp_str:=('NEWFPROT.LOG');
     assign(newfile,'NEWFPROT.LOG');
     call_buffer;
     settextbuf(newfile,tbuff^,tbuffsize);
     {$I-}
     reset(newfile);
     {$I+}
     count:=1;
     while IOResult = 0 do
     begin
         close(newfile);
         str(count,tmp_str);
         for i:=1 to 1-length(tmp_str) do tmp_str:=tmp_str;
         tmp_str:=concat('NEWFPROT.LO'+tmp_str);
         inc(count);
         assign(newfile,tmp_str);
         call_buffer;
         settextbuf(newfile,tbuff^,tbuffsize);
         {$I-}
         reset(newfile);
         {$I+}
     end;

     rewrite(newfile);

     count := 0;
     log_file:=tmp_str;

     repeat
           readln(log,instring);
           space_position:=pos('ection: ',instring);
           if space_position > 0 then
                begin
                     virusname := instring;
                     delete(virusname,1,space_position+7);
                     if pos('New or',virusname) > 0 then
                                                        begin
                                                        delete(virusname,1,pos('of ',virusname)+2);
                                                        virusname:=concat(virusname+'.variant');
                                                        end;
                     if (parm1 = '-CS') or (parm1 = '-CSW') then
                     else if pos(' ',virusname) > 0 then delete(virusname,pos(' ',virusname),length(virusname));
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(newfile,instring);
                     end;
                end;
     until eof(log);
     if count=0 then no_new_virii_found
     else
         begin
         writeln(count,' new F-Prot virii found...');
         writeln;
         end;

     Cierra_diccionarios;

     close(newfile);
     close(log);
longitud(log_file);
end;
end;

procedure AddNewDAT_A(logname:string);
begin
     writeln('Adding virii from ',logname);
     writeln('Detected AVP log file');
     reset(log);

     inicializa_diccionarios;

     assign(f,'avp.dat');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     {$I-}
     reset(f);
     {$I+}
     if IOResult <> 0 then not_find_avp
     else
     begin
     repeat
           readln(f,virusname);
           delete(virusname,1,pos(#1,virusname));
           escribe_diccionario;
     until eof(f);
     close(f);

     if (parm1 = '-AL') or (parm1 = '-ALS') then
     begin
     tmp_str:=('NEWAVP.LOG');
     assign(newfile,tmp_str);
     call_buffer;
     settextbuf(newfile,tbuff^,tbuffsize);
     {$I-}
     reset(newfile);
     {$I+}
     count:=1;
     while IOResult = 0 do
     begin
         close(newfile);
         str(count,tmp_str);
         for i:=1 to 1-length(tmp_str) do tmp_str:=tmp_str;
         tmp_str:=concat('NEWAVP.LO'+tmp_str);
         inc(count);
         assign(newfile,tmp_str);
         call_buffer;
         settextbuf(newfile,tbuff^,tbuffsize);
         {$I-}
         reset(newfile);
         {$I+}
     end;
         rewrite(newfile);
         log_file:=tmp_str;
                                                   end;

     count := 0;
     append(f);

     repeat
           readln(log,instring);
                     flag1 := false;
                     filename := instring;
                     virusname := instring;
                     if pos('infected:',filename) > 0 then
                     begin
                     for last_bar:=length(filename) downto 0 do if filename[last_bar]=':' then break;
                     delete(filename,last_bar-9,length(filename));
                     delete(virusname,1,last_bar+1);
                     flag1 := true;
                     end
                     else if pos('warning:',filename) > 0 then
                     begin
                     for last_bar:=length(filename) downto 0 do if filename[last_bar]=':' then break;
                     delete(filename,last_bar-8,length(filename));
                     delete(virusname,1,last_bar+1);
                     virusname := virusname+'.warning';
                     flag1 := true;
                     end;
                     if flag1 = true then
                     begin
                     if pos(' ',virusname) >0 then
                                                  begin
                                                  tmp_str:=copy(virusname,1,pos(' ',virusname)-1);
                                                  delete(virusname,1,pos(' ',virusname));
                                                  virusname:=concat(tmp_str+'_'+virusname);
                                                  end;
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(f,filename,#1,virusname);
                          if (parm1 = '-AL') or (parm1 = '-ALS') then writeln(newfile,instring);
                     end;
                     end;
     until eof(log);
     if count=0 then no_new_virii_added
     else
         begin
         writeln('Added ',count,' new virii for AVP...');
         writeln;
         end;

     Cierra_diccionarios;

     close(f);
     close(log);
     if (parm1 = '-AL') or (parm1 = '-ALS') then
                                                   begin
                                                   close(newfile);
                                                   longitud(log_file);
                                                   end;
end;
end;

procedure AddNewDAT_F(logname:string);
begin
     writeln('Adding virii from ',logname);
     writeln('Detected F-Prot log file');
     reset(log);

     inicializa_diccionarios;

     assign(f,'fprot.dat');
     call_buffer;
     settextbuf(f,tbuff^,tbuffsize);
     {$I-}
     reset(f);
     {$I+}
     if IOResult <> 0 then not_find_fprot
     else
     begin
     repeat
           readln(f,virusname);
           delete(virusname,1,pos(#1,virusname));
           escribe_diccionario;
     until eof(f);
     close(f);

     if (parm1 = '-AL') or (parm1 = '-ALS') then
     begin
     tmp_str:=('NEWFPROT.LOG');
     assign(newfile,tmp_str);
     call_buffer;
     settextbuf(newfile,tbuff^,tbuffsize);
     {$I-}
     reset(newfile);
     {$I+}
     count:=1;
     while IOResult = 0 do
     begin
         close(newfile);
         str(count,tmp_str);
         for i:=1 to 1-length(tmp_str) do tmp_str:=tmp_str;
         tmp_str:=concat('NEWFPROT.LO'+tmp_str);
         inc(count);
         assign(newfile,tmp_str);
         call_buffer;
         settextbuf(newfile,tbuff^,tbuffsize);
         {$I-}
         reset(newfile);
         {$I+}
     end;
         rewrite(newfile);
         log_file:=tmp_str;
                                                   end;

     count := 0;
     append(f);

     repeat
           readln(log,instring);
           space_position:=pos('ection: ',instring);
           if space_position > 0 then
                begin
                     filename := instring;
                     virusname := instring;
                     delete(filename,space_position-5,length(filename));
                     delete(virusname,1,space_position+7);
                     if pos('New or',virusname) > 0 then
                                                        begin
                                                        delete(virusname,1,pos('of ',virusname)+2);
                                                        virusname:=concat(virusname+'.variant');
                                                        end;
                     if (parm1 = '-AS') or (parm1 = '-ALS') then
                     else if pos(' ',virusname) > 0 then delete(virusname,pos(' ',virusname),length(virusname));
                     escribe_diccionario;
                     if test < 0 then
                     begin
                          inc(count);
                          writeln(f,filename,#1,virusname);
     if (parm1 = '-AL') or (parm1 = '-ALS') then writeln(newfile,instring);
                     end;
                end;
     until eof(log);
     if count=0 then no_new_virii_added
     else
         begin
         writeln('Added ',count,' new virii for F-Prot...');
         writeln;
         end;

     Cierra_diccionarios;

     close(f);
     close(log);
     if (parm1 = '-AL') or (parm1 = '-ALS') then
                                                   begin
                                                   close(newfile);
                                                   longitud(log_file);
                                                   end;
end;
end;

procedure CountViruses;
begin

      flag1 := false;

      assign(f,'avp.dat');
      {$I-}
      reset(f);
      {$I+}
      if IOResult = 0 then
                          begin
                          flag1 := true;
                          count:= 0;
                          if parm1 = '-H' then
                                              begin
                                              repeat
                                              readln(f,temp_string);
                                              count := count + 1;
                                              until eof(f);
                                              writeln(count,' virii for AVP');
                                              end
                          else
                              begin
                              repeat
                              readln(f,temp_string);
                              if pos('warning',temp_string) > 0 then
                              else count := count + 1;
                              until eof(f);
                              writeln(count,' unique virii for AVP');
                              end;
                          close(f);
                          end;

      assign(f,'fprot.dat');
      {$I-}
      reset(f);
      {$I+}
      if IOResult = 0 then
                          begin
                          flag1 := true;
                          count := 0;
                          if parm1 = '-H' then
                                              begin
                                              repeat
                                              readln(f,temp_string);
                                              count := count + 1;
                                              until eof(f);
                                              writeln(count,' virii for F-Prot');
                                              end
                          else
                              begin
                              repeat
                              readln(f,temp_string);
                              if (pos('unknown?',temp_string) > 0) or
                                 (pos('damaged?',temp_string) > 0) then
                              else count := count + 1;
                              until eof(f);
                              writeln(count,' unique virii for F-Prot');
                              end;
                          close(f);
                          end;

      if flag1 = false then no_dat;
      halt;
end;

procedure BuildNew;

begin
     DetectLog;
     if tipo = 'AVP' then BuildNewDat_A(parm2)
     else if tipo = 'F-PROT' then BuildNewDat_F(parm2)
     else no_virii;
end;

procedure CompareDat;
begin
     DetectLog;
     if tipo = 'AVP' then CompareDat_A(parm2)
     else if tipo = 'F-PROT' then CompareDat_F(parm2)
     else no_virii;
end;

procedure AddNewDat;
begin
     DetectLog;
     if tipo = 'AVP' then AddNewDat_A(parm2)
     else if tipo = 'F-PROT' then AddNewDat_F(parm1)
     else no_virii;
end;

begin
     writeln;
     writeln('   Virsort 2000 Special Edition for 29A #5                 by VirusBuster/29A');
     writeln('-=----------------------------------------------------------------------------=-');

parm1 := paramstr(1);
parm2 := paramstr(2);
parm3 := paramstr(3);

for i := 1 to Length(parm1) do parm1[i] := UpCase(parm1[i]);
for i := 1 to Length(parm2) do parm2[i] := UpCase(parm2[i]);
for i := 1 to Length(parm3) do parm3[i] := UpCase(parm3[i]);

if (parm1 = '') or (parm1[1] <> '-') then ShowHelp;

if parm1[2] = 'H' then CountViruses
else OpenLog(parm2);
if flag2 = True then
                    begin
                    writeln('Log file not found!');
                    halt;
                    end
else
    begin
    if parm1[2] = 'B' then BuildNew
    else if parm1[2] = 'C' then CompareDAT
    else if parm1[2] = 'A' then AddNewDAT
    else writeln('Unknown command. Run VS2000 without parameters for help!');
    close(log);
    end;
writeln;
end.
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[VS2000.PAS]ÄÄÄ
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[LGARRAY.PAS]ÄÄÄ
unit lgArray;
interface
type longArray=record name: string[40];
                      private: array[1..35] of byte
     end;
     stringPtr=^string;

    longintPtr=^longint;
    dictionary=record name: string[40];
                    index,corpus: longArray;
                    frequency: longint;
                    fqPtr: longintPtr;
     end;

procedure memAssign(var a: longArray; st: string);
procedure memRewrite(var a: longArray; items: longint; itemSize: word);
procedure memSeek(var a: longArray; item: longint);
procedure memRead(var a: longArray; var item);
procedure memWrite(var a: longArray; var item);
procedure memSeekAndRead(var a: longArray; i: longint; var item);
procedure memSeekAndWrite(var a: longArray; i: longint; var item);
procedure memPut(var a: longArray; var item);
procedure memClose;
procedure memErase(var a: longArray);
function  memFileSize(var a: longArray):longint;
function  memLast(var a: longArray): longint;
function  memFilePos(var a: longArray): longint;

procedure dicAssign(var d: dictionary; st: string);
procedure dicRewrite(var d: dictionary; items: longint);
procedure dicFind(var d: dictionary; st: string; var foundPos: longint);
procedure dicWrite(var d: dictionary; st: string; var i: longint);
procedure dicPut(var d: dictionary; st: string);
procedure dicSeekAndWrite(var d: dictionary; i: longint; st: string);
procedure dicClose;
procedure dicErase(var d: dictionary);

procedure SetFq(var st: string; fq: longint);
procedure GetFq(var st: string; var fq: longint);

const expectedWordLength=10;

type aRowPtr=^aRow;
     aDictionaryPtr=^dictionary;
     anIndex=array[0..0] of aRowPtr;
     anIndexPtr=^anIndex;
     aRow= array[0..0] of byte;

     memRec=object
       name: string[40];
       bytesPerRow,bytesInIndex,lastRow,recordsPerRow,
       bytesPerRecord,shift,mask: word;
       maxRecordsInArray,lastRecord,pos: longint;
       insertMode: boolean;
       rowPtrNo: anIndexPtr;
       dicPtr:   aDictionaryPtr;
     end;

implementation

uses crt;

procedure SetFq(var st: string; fq: longint);
begin if length(st)>251 then st[0]:=#251;
      move(fq,st[length(st)+1],4); inc(st[0],4);
end;

procedure GetFq(var st: string; var fq: longint);
begin dec(st[0],4);
      move(st[length(st)+1],fq,4)
end;

procedure MemAssign(var a: longArray; st: string);
begin a.name:=st
end;

procedure MemRewrite(var a: longArray; items: longint; itemSize: word);
var i: word; n: longint;
begin
    FillChar(a.Private,SizeOf(a.Private),0);
    with memRec(a) do
begin
   bytesPerRecord:=itemSize;
   recordsPerRow:=65520 div bytesPerRecord;
   if recordsPerRow>items then recordsPerRow:=items;
   n:=32768; shift:=15;
   while (n>recordsPerRow) and (n>2) do begin n:=n div 2; dec(shift) end;
   mask:=(1 shl shift) -1;
   recordsPerRow:=n;
   bytesPerRow:=recordsPerRow * bytesPerRecord;
   lastRow:=items div recordsPerRow; (* first Row = 0 *)
   maxRecordsInArray:=longint(lastRow+1) * longint(recordsPerRow);
   lastRecord:=-1;
   bytesInIndex:=(lastRow+1)*sizeOf(pointer);
   GetMem(rowPtrNo,bytesInIndex);
   for i:=0 to lastRow do
   begin
         GetMem(rowPtrNo^[i],bytesPerRow);
         FillChar(rowPtrNo^[i]^,bytesPerRow,0)
   end;
end
end;

procedure MemExpand(var a: longArray; items: longint);
var newLastRow,bytesInNewIndex,i: word;
    newIndex_: anIndexPtr;
begin with memRec(a) do
begin
   newLastRow:=(items) div recordsPerRow;
   if newLastRow<=lastRow then exit;
   bytesInNewIndex:=(newLastRow+1)*sizeOf(pointer);


   GetMem(newIndex_,bytesInNewIndex);
   Move(rowPtrNo^,newIndex_^,bytesInIndex);
   FreeMem(rowPtrNo,bytesInIndex);
   rowPtrNo:=newIndex_;
   for i:=lastRow+1 to newLastRow do
   begin
         GetMem(rowPtrNo^[i],bytesPerRow);
         FillChar(rowPtrNo^[i]^,bytesPerRow,0);
   end;
   lastRow:=newLastRow;
   bytesInIndex:=bytesInNewIndex;
   maxRecordsInArray:=(lastRow+1)*recordsPerRow;
end
end;

procedure memReadString(var a: longArray; var st: string);
var row,col,lgth: word;
    stPtr: stringPtr;
begin with memRec(a) do
begin
      row:= pos shr shift;
      col:=(pos and mask);
      stPtr:=addr(rowPtrNo^[row]^[col]);
      lgth:=length(stPtr^)+1;
      Move(stPtr^,st,lgth);
      inc(pos,lgth);
end
end;

procedure memReadStringPtr(var a: longArray; var st: stringPtr);
var row,col: word;
begin with memRec(a) do
begin
      row:= pos shr shift;
      col:=(pos and mask);
      st:=addr(rowPtrNo^[row]^[col]);
end
end;

procedure MemWriteString(var a: longArray; st: string);
var row,col,lgth: word;
begin with memRec(a) do
begin lgth:=length(st)+1;
      row:= pos shr shift;
      col:=(pos and mask);
      if col+lgth>bytesPerRow-1
      then
      begin inc(row); col:=0;
            if row>lastRow then
            MemExpand(a,longint(row+1)*bytesPerRow);
      end;
      Move(st,rowPtrNo^[row]^[col],lgth);
      lastRecord:=longint(row)*bytesPerRow+col+lgth-1;
      pos:=lastRecord+1;
end
end;

procedure MemSeek(var a: longArray; item: longint);
begin with memRec(a) do
begin if (item<0) then Exit;
      if (item>maxRecordsInArray) then MemExpand(a,item);
      pos:=item;
end;
end;

procedure memMoveVar(var a: longArray; pos1,pos2,itemsToMove: longint);
var newlastRecord: longint;
    itemsFromSource,itemsIntoTarget: word;
    res, {Row of end of source }
    rss, {Row of start of source }
    ces, {Col of end of source }
    ret, {Row of end of target }
    cet  {Col of end of target }
    : word;
begin with MemRec(a) do
begin newlastRecord:=pos2+itemsToMove-1;
      if newLastRecord<lastRecord then newLastRecord:=lastRecord;
      lastRecord:=newLastRecord;
      if newLastRecord>=maxRecordsInArray then
      begin MemExpand(a,newlastRecord);
      end;
      rss:=pos1 div recordsPerRow;
      inc(pos1,itemsToMove-1); inc(pos2,itemsToMove-1);
      res:=pos1 div recordsPerRow;
      ret:=pos2 div recordsPerRow;
      ces:=pos1 mod recordsPerRow;
      cet:=pos2 mod recordsPerRow;
      repeat
             if rss=res then
             itemsFromSource:=itemsToMove
             else itemsFromSource:=ces+1;
             itemsIntoTarget:=cet+1;
             if itemsFromSource>itemsIntoTarget
             then itemsFromSource:=itemsIntoTarget;
                  Move(rowPtrNo^[res]^[bytesPerRecord*(ces+1-itemsFromSource)],
                  rowPtrNo^[ret]^[bytesPerRecord*(cet+1-itemsFromSource)],
                  itemsFromSource*bytesPerRecord);
             dec(itemsToMove,itemsFromSource);
             dec(pos1,itemsFromSource);
             res:=pos1 div recordsPerRow;
             ces:=pos1 mod recordsPerRow;
             dec(pos2,itemsFromSource);
             ret:=pos2 div recordsPerRow;
             cet:=pos2 mod recordsPerRow;
      until itemsToMove=0;
end
end;

procedure memPutVar(var a: longArray; var what);
var row,col: word;
    dummy: byte absolute what;
begin with memRec(a) do
begin
      if pos+1>maxRecordsInArray then BEGIN
        MemExpand(a,pos);
      END;
      if pos>lastRecord then lastRecord:=pos;
      row:= pos shr shift;
      col:=(pos and mask) * bytesPerRecord;
      Move(dummy,rowPtrNo^[row]^[col],bytesPerRecord);
end;
end;

procedure memInsertVar(var a: longArray; var what);
var row,col: word;
    dummy: byte absolute what;
begin with memRec(a) do
begin if pos<=lastRecord
      then memMoveVar(a,pos,pos+1,lastRecord-pos+1)
      else
      begin if pos+1>maxRecordsInArray then MemExpand(a,pos);
            if pos>lastRecord then lastRecord:=pos;
      end;
      row:= pos shr shift;
      col:=(pos and mask) * bytesPerRecord;
      Move(dummy,rowPtrNo^[row]^[col],bytesPerRecord);
end;
end;

procedure MemRead(var a: longArray; var item);
var row,col: word; dummy: byte absolute item;
begin with MemRec(a) do
begin
    if pos>lastRecord then FillChar(dummy,bytesPerRecord,0)
    else
    begin
      row:= pos shr shift;
      col:=(pos and mask) * bytesPerRecord;
      Move(rowPtrNo^[row]^[col],dummy,bytesPerRecord);
      inc(pos)
    end
end
end;

procedure MemWrite(var a: longArray; var item);
var anon: byte absolute item;
begin with memRec(a) do
begin
       if insertMode then MemInsertVar(a,anon)
       else MemPutVar(a,anon);
       inc(pos)
end;
end;

procedure MemPut(var a: longArray; var item);
var anon: byte absolute item;
begin with memRec(a) do
begin if insertMode then MemInsertVar(a,anon)
      else MemPutVar(a,anon);
end;
end;

procedure MemSeekAndWrite(var a: longArray; i: longint; var item);
var anon: byte absolute item;
begin with memRec(a) do
begin pos:=i;
      if insertMode then MemInsertVar(a,anon)
      else MemPutVar(a,anon);
      inc(pos);
end;
end;

procedure MemSeekAndRead(var a: longArray; i: longint; var item);
var row,col: word; dummy: byte absolute item;
begin with MemRec(a) do
begin pos:=i;
    if pos>lastRecord then FillChar(dummy,bytesPerRecord,0)
    else
    begin
      row:= pos shr shift;
      col:=(pos and mask) * bytesPerRecord;
      Move(rowPtrNo^[row]^[col],dummy,bytesPerRecord);
      inc(pos)
    end
end
end;

procedure MemSetInsertMode(var a: longArray; onOff: boolean);
begin memRec(a).insertMode:=onOff
end;

procedure MemClose;
begin
end;

procedure MemErase(var a: longArray);
var i: word;
begin with MemRec(a) do
begin for i:=lastRow downto 0 do
      FreeMem(rowPtrNo^[i],bytesPerRow);
      FreeMem(rowPtrNo,bytesInIndex);
end
end;

function MemLast(var a: longArray): longint;
begin MemLast:=memRec(a).lastRecord
end;

function  MemFileSize(var a: longArray):longint;
begin MemFileSize:=memRec(a).lastRecord+1
end;

function  MemFilePos(var a: longArray): longint;
begin MemFilePos:=memRec(a).pos
end;

procedure dicAssign(var d: dictionary; st: string);
begin with d do
begin name:=st;
      memAssign(index,'index'); memAssign(corpus,'corpus');
end
end;

procedure dicRewrite(var d: dictionary; items: longint);
var null: string;
begin with d do
begin memRewrite(index,items,SizeOf(pointer));
      memSetInsertMode(index,true);
      items:=items*(expectedWordLength+5);
      if items<256 then items:=256;
      memRewrite(corpus,items,sizeOf(char));
      memRec(index).dicPtr:=@d;
      memRec(corpus).dicPtr:=@d;
end;
      null:='';
      dicPut(d,null);
end;

procedure dicClose;
begin
end;

procedure dicErase(var d: dictionary);
begin memErase(d.corpus); memErase(d.index)
end;

procedure dicFind(var d: dictionary; st: string; var foundPos: longint);
var lo,mid,hi,posInCorpus,oldPos: longint; found: boolean;
    tmpPtr: stringPtr; tmp: string;
begin with d do
begin found:=false; lo:=0; hi:=memFileSize(index)-1;
      oldPos:=memRec(corpus).pos;
      while (lo<=hi) and not found do
      begin mid:=(lo+hi) div 2;
         memSeekAndRead(index,mid,posInCorpus);
         memSeek(corpus,posInCorpus);
         memReadStringPtr(corpus,tmpPtr);
         tmp:=tmpPtr^;
         GetFq(tmp,frequency);
         if st>tmp then lo:=mid+1 else
         if st<tmp then hi:=mid-1 else
         if st=tmp then found:=true;
      end;
      if found then
      begin FoundPos:=mid;
            fqPtr:=longintPtr(longint(tmpPtr)+length(tmp)+1);
      end
      else foundPos:=-lo;
      memRec(corpus).pos:=oldPos;
end;
end;

procedure dicPut(var d: dictionary; st: string);
var indexPos: longint;
begin with d do
begin
      SetFq(st,1);
      memWriteString(corpus,st);
      indexPos:=memFileSize(corpus)-(length(st)+1);
      memWrite(index,indexPos);
end
end;

procedure dicSeekAndWrite(var d: dictionary; i: longint; st: string);
var corpusPos: longint;
begin with d do
begin SetFq(st,1);
      memWriteString(corpus,st);
      corpusPos:=memFilePos(corpus)-(length(st)+1);
      memSeekAndWrite(index,i,corpusPos);
end
end;


procedure dicWrite(var d: dictionary; st: string; var i: longint);
begin dicFind(d,st,i);
      if i<0 then dicSeekAndWrite(d,-i,st)
      else inc(d.fqPtr^);
end;
end.
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[LGARRAY.PAS]ÄÄÄ
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[COMMENT.TXT]ÄÄÄ
   Black Cat has been accusing me about i stole his VSNG source code and i
used it to improve VS2000's speed. All  this time i have been saying Black
Cat was  lying, and now it's  the time to  prove it... Sorry for you Black
Cat, but you are going to be remembered as a big lamer and liar.

   Here i release an optimized version of the VS2000 version i released in
29A #4. As you can see, the code is the same, the main modification is the
optimization of speed i got distributing the work in several dictionaries.

   You can compare VS2000 8.88 speed, last version of official VS200, with
this version, and you will notice is the same. That means VS2000 never has
used any code from VSNG, as i have told  many times already.

   The question about if i stole Black Cat's code is finally over!

   VirusBuster/29A
ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[COMMENT.TXT]ÄÄÄ