Советы по Delphi

         

Работа с индексами Clipper'а


Валентин Чесноков пишет:

Посылаю кое-что из своих наработок: NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным Clipper приложений. Предусмотрено, что программа может работать с индексом даже если родное приложение производит изменение в индексе NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в заголовке, очень было лениво, да и торопился) До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"

Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)

В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона

Файл Eurst.inc

    var vrSynonm:integer=0; vrPhFine:integer=0; vrUrFine:integer=0; vrStrSyn:integer=0;


function fContxt(const s:ShortString):ShortString;
var i:integer;
r:ShortString; c,c1:char; begin r:=''; c1:=chr(0);
for i:=1 to length(s) do begin c:=s[i]; if c='Ё' then c:='Е'; if not (c in ['А'..'Я','A'..'Z','0'..'9','.']) then c:=' '; if (c=c1)and not (c1 in ['0'..'9'])  then continue; c1:=c; if (c1 in ['А'..'Я'])and(c='-')and(i<length(s))and(s[i+1]=' ') then begin c1:=' '; continue; end; r:=r+c; end; procedure _Cut(var s:ShortString;p:ShortString);
begin
if
Pos(p,s)=length(s)-length(p)+1 then s:=Copy(s,1,length(s)-length(p)); end;

function _PhFace(const ss:ShortString):ShortString;
var r:ShortString;
i:integer; s:ShortString; begin r:=''; s:=ANSIUpperCase(ss); if length(s)<2 then begin Result:=s; exit; end; _Cut(s,'ЕВИЧ'); _Cut(s,'ОВИЧ'); _Cut(s,'ЕВНА'); _Cut(s,'ОВНА'); for i:=1 to length(s) do begin if length(r)>12 then break; if not(s[i] in ['А'..'Я','Ё','A'..'Z']) then break; if (s[i]='Й')and((i=length(s)) or(not (s[i+1] in ['А'..'Я','Ё','A'..'Z']))) then continue; {ЕЯ-ИЯ Андриянов} if s[i]='Е' then if (i>length(s))and(s[i+1]='Я') then s[i]:='И'; {Ж,З-С Ахметжанов} if s[i]in ['Ж','З'] then s[i]:='С'; {АЯ-АЙ Шаяхметов} if s[i]='Я' then if (i>1)and(s[i-1]='А') then s[i]:='Й'; {Ы-И Васылович} if s[i] in ['Ы','Й'] then s[i]:='И'; {АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович} if s[i] in ['Г','Д'] then if (i>1) and (i<length(s)) then if (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue; {О-А Арефьев, Родионов} if s[i]='О' then s[i]:='А'; {ИЕ-Е Галиев} if s[i]='И' then if (i>length(s))and(s[i+1]='Е') then continue; {Ё-Е Ковалёв} if s[i]='Ё' then s[i]:='Е'; {Э-И Эльдар} if s[i]='Э' then s[i]:='И'; {*ЯЕ-*ЕЕ Черняев} {(И|С)Я*-(И|С)А* Гатиятуллин} if s[i]='Я' then if (i>1)and(i<length(s)) then begin if s[i+1]='Е' then s[i]:='Е'; if s[i-1] in ['И','С'] then s[i]:='А'; end; {(А|И|Е|У)Д-(А|И|Е|У)Т Мурад} if s[i]='Д' then if (i>1)and(s[i-1] in ['А','И','Е','У']) then s[i]:='Т'; {Х|К-Г Фархат} if s[i] in ['Х','К'] then s[i]:='Г'; if s[i] in ['Ь','Ъ'] then continue; {БАР-БР Мубракзянов} if s[i]='А' then if (i>1)and(i>length(s)) then if (s[i-1]='Б')and(s[i+1]='Р') then continue; {ИХО-ИТО Вагихович} if s[i] in ['Х','Ф','П'] then if (i>1)and(i<length(s)) then if (s[i-1]='И')and(s[i+1]='О') then s[i]:='Т'; {Ф-В Рафкат} if s[i]='Ф' then s[i]:='В'; {ИВ-АВ Ривкат см. Ф} if s[i]='И' then if (i<length(s))and(s[i+1]='В') then s[i]:='А'; {АГЕ-АЕ Зулкагетович, Сагитович, Сабитович} if s[i] in ['Г','Б'] then if (i>1)and(i<length(s)) then if (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue; {АУТ-АТ Зияутдинович см. ИЯ} if s[i]='У' then if (i>1)and(i<length(s)) then if (s[i-1]='А')and(s[i+1]='Т') then continue; {АБ-АП Габдельнурович} if s[i]='Б' then if (i>1)and(s[i-1]='A') then s[i]:='П'; {ФАИ-ФИ Рафаилович} if s[i]='А' then if (i>1)and(i<length(s)) then if (s[i-1]='Ф')and(s[i+1]='И') then continue; {ГАБД-АБД} if s[i]='Г' then if (i=1)and(length(s)>3)and(s[i+1]='А')and(s[i+2]='Б')and(s[i+3]='Д') then continue; {РЕН-РИН Ренат} if s[i]='Е' then if (i>1)and(i<length(s)) then if (s[i-1]='Р')and(s[i+1]='Н') then s[i]:='И'; {ГАФ-ГФ Ягофар} if s[i]='А' then if (i>1)and(i<length(s)) then if (s[i-1]='Г')and(s[i+1]='Ф') then continue; {??-? Зинатуллин} if (i>1)and(s[i]=s[i-1]) then continue; r:=r+s[i]; end; Result:=r; end;

Файл NtxAdd.pas

    unit NtxAdd;

interface

uses
classes,SysUtils,NtxRO;

type
TNtxAdd=class(TNtxRO) protected function  Changed:boolean; override; function  Add(var s:ShortString;var rn:integer;var nxt:integer):boolean; procedure NewRoot(s:ShortString;rn:integer;nxt:integer); virtual; function  GetFreePtr(p:PBuf):Word; public constructor Create(nm:ShortString;ks:Word); constructor Open(nm:ShortString); procedure   Insert(key:ShortString;rn:integer); end;
implementation

function
TNtxAdd.GetFreePtr(p:PBuf):Word;
var i,j:integer;
r:Word; fl:boolean; begin
r:=(max+2)*2; for i:=1 to max+1 do begin fl:=True; for j:=1 to GetCount(p)+1 do if GetCount(PBuf(@(p^[j*2])))=r then fl:=False; if fl then begin Result:=r; exit; end; r:=r+isz; end; Result:=0; end;

function TNtxAdd.Add(var s:ShortString;var rn:integer;var nxt:integer):boolean;
var p:PBuf;
w,fr:Word; i:integer; tmp:integer; begin
with
tr do begin p:=GetPage(h,(TTraceRec(Items[Count-1])).pg); if GetCount(p)then begin fr:=GetFreePtr(p); if fr=0 then begin Self.Error:=True; Result:=True; exit; end; w:=GetCount(p)+1; p^[0]:=w and $FF; p^[1]:=(w and $FF00)shr 8; w:=(TTraceRec(Items[Count-1])).cn; for i:=GetCount(p)+1 downto w+1 do begin p^[2*i]  :=p^[2*i-2]; p^[2*i+1]:=p^[2*i-1]; end; p^[2*w]  := fr and $FF; p^[2*w+1]:=(fr and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; FileSeek(h,(TTraceRec(Items[Count-1])).pg,0); FileWrite(h,p^,1024); Result:=True; end else begin fr:=GetCount(p)+1; fr:=GetCount(PBuf(@(p^[fr*2]))); w:=(TTraceRec(Items[Count-1])).cn; for i:=GetCount(p)+1 downto w+1 do begin p^[2*i]  :=p^[2*i-2]; p^[2*i+1]:=p^[2*i-1]; end; p^[2*w]  := fr and $FF; p^[2*w+1]:=(fr and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; tmp:=0; for i:=3 downto 0 do tmp:=$100*tmp+p^[fr+i]; for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; w:=hlf; p^[0]:=w and $FF; p^[1]:=(w and $FF00)shr 8; fr:=GetCount(PBuf(@(p^[(hlf+1)*2]))); s:=''; rn:=0; for i:=0 to ksz-1 do begin s:=s+chr(p^[fr+8+i]); p^[fr+8+i]:=0; end; for i:=3 downto 0 do begin rn:=$100*rn+p^[fr+i+4]; p^[fr+i+4]:=0; end; nxt:=FileSeek(h,0,2); FileWrite(h,p^,1024); for i:=1 to hlf do begin p^[2*i]  :=p^[2*(i+hlf+1)]; p^[2*i+1]:=p^[2*(i+hlf+1)+1]; end; for i:=0 to 3 do begin p^[fr+i]:=tmp mod $100; tmp:=tmp div $100; end; FileSeek(h,(TTraceRec(Items[Count-1])).pg,0); FileWrite(h,p^,1024); Result:=False; end; end; end;

procedure TNtxAdd.NewRoot(s:ShortString;rn:integer;nxt:integer);
var p:PBuf;
i,fr:integer; begin
p:=GetPage(h,0); for i:=0 to 1023 do p^[i]:=0; fr:=(max+2)*2; p^[0]:=1; p^[2]:=fr  and $FF; p^[3]:=(fr  and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; fr:=fr+isz; p^[4]:=fr and $FF; p^[5]:=(fr  and $FF00)shr 8; nxt:=GetRoot; for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; nxt:=FileSeek(h,0,2); FileWrite(h,p^,1024); FileSeek(h,4,0); FileWrite(h,nxt,sizeof(integer)); end;

procedure TNtxAdd.Insert(key:ShortString;rn:integer);
var nxt:integer;
i:integer; begin nxt:=0; if DosFl then key:=WinToDos(key); if length(key)>ksz then key:=Copy(key,1,ksz); for i:=1 to ksz-length(key) do key:=key+' '; Clear; Load(GetRoot); Seek(key,False); while True do begin if Add(key,rn,nxt) then break; if tr.Count=1 then begin NewRoot(key,rn,nxt); break; end; Pop; end; end;

constructor TNtxAdd.Create(nm:ShortString;ks:Word);
var p:PBuf;
i:integer; begin
Error:=False; DeleteFile(nm); h:=FileCreate(nm); if h>0 then begin p:=GetPage(h,0); for i:=0 to 1023 do p^[i]:=0; p^[14]:=ks and $FF; p^[15]:=(ks and $FF00)shr 8; ks:=ks+8; p^[12]:=ks and $FF; p^[13]:=(ks and $FF00)shr 8; i:=(1020-ks)div(2+ks); i:=i div 2; p^[20]:=i  and $FF; p^[21]:=(i  and $FF00)shr 8; i:=i*2; max:=i; p^[18]:=i  and $FF; p^[19]:=(i  and $FF00)shr 8; i:=1024; p^[4 ]:=i  and $FF; p^[5 ]:=(i  and $FF00)shr 8; FileWrite(h,p^,1024); for i:=0 to 1023 do p^[i]:=0;                    i:=(max+2)*2; p^[2 ]:=i  and $FF; p^[3 ]:=(i  and $FF00)shr 8; FileWrite(h,p^,1024); end else Error:=True; FileClose(h); FreeHandle(h); Open(nm); end;

constructor TNtxAdd.Open(nm:ShortString);
begin
Error:=False; h:=FileOpen(nm,fmOpenReadWrite or fmShareExclusive); if h>0 then begin FileSeek(h,12,0); FileRead(h,isz,2); FileSeek(h,14,0); FileRead(h,ksz,2); FileSeek(h,18,0); FileRead(h,max,2); FileSeek(h,20,0); FileRead(h,hlf,2); DosFl:=True; tr:=TList.Create; end else Error:=True; end;

function TNtxAdd.Changed:boolean;
begin
Result:=(csize=0); csize:=-1; end;

end.

Файл NtxRO.pas

    unit NtxRO;

interface

uses
Classes;

type  TBuf=array[0..1023]of Byte;
PBuf=^TBuf; TTraceRec=class public pg:integer; cn:SmallInt; constructor Create(p:integer;c:SmallInt); end; TNtxRO=class protected fs:string[10]; empty:integer; csize:integer; rc:integer;                       {Текущий номер записи} tr:TList;                         {Стек загруженных страниц} h:integer;                        {Дескриптор файла} isz:Word;                          {Размер элемента} ksz:Word;                          {Размер ключа} max:Word;                          {Максимальное кол-во элементов} hlf:Word;                          {Половина страницы} function  GetRoot:integer;         {Указатель на корень} function  GetEmpty:integer;        {Пустая страница} function  GetSize:integer;         {Возвращает размер файла} function  GetCount(p:PBuf):Word;   {Число элементов на странице} function  Changed:boolean; virtual; procedure Clear; function  Load(n:integer):PBuf; function  Pop:PBuf; function  Seek(const s:ShortString;fl:boolean):boolean; function  Skip:PBuf; function  GetItem(p:PBuf):PBuf; function  GetLink(p:PBuf):integer; public Error:boolean; DosFl:boolean; constructor Open(nm:ShortString); destructor  Destroy; override; function    Find(const s:ShortString):boolean; function    GetString(p:PBuf;c:SmallInt):ShortString; function    GetRecN(p:PBuf):integer; function    Next:PBuf; end;
function  GetPage(h,fs:integer):PBuf;
procedure FreeHandle(h:integer);
function  DosToWin(const ss:ShortString):ShortString;
function  WinToDos(const ss:ShortString):ShortString;

implementation

uses
  Windows, SysUtils;

const MaxPgs=5;
var   Buf:array[1..1024*MaxPgs]of char;
Cache:array[1..MaxPgs]of record Handle:integer; {0-страница свободна} Offset:integer; {  смещение в файле} Countr:integer; {  счетчик использования} Length:SmallInt; end;
function TNtxRO.Next:PBuf;
var cr:integer;
p:PBuf; begin
if
h<=0 then begin Result:=nil; exit; end; while Changed do begin cr:=rc; Find(fs); while cr>0 do begin p:=Skip; if GetRecN(p)=cr then break; end; end; Result:=Skip; end;

function TNtxRO.Skip:PBuf;
var cnt:boolean;
p,r:PBuf; n:integer; begin r:=nil;
cnt:=True; with tr do begin p:=GetPage(h,(TTraceRec(Items[Count-1])).pg); while cnt do begin cnt:=False; if (TTraceRec(Items[Count-1])).cn>GetCount(p)+1 then begin if Count<=1 then begin Result:=nil; exit; end; p:=Pop; end else while True do begin r:=GetItem(p); n:=GetLink(r); if n=0 then break; p:=Load(n); end; if (TTraceRec(Items[Count-1])).cn>=GetCount(p)+1 then cnt:=True else r:=GetItem(p); Inc((TTraceRec(Items[Count-1])).cn); end; end; if r<>nil then begin rc:=GetRecN(r); fs:=GetString(r,length(fs)); end; Result:=r; end;

function TNtxRO.GetItem(p:PBuf):PBuf;
var r:PBuf;
begin
with
TTraceRec(tr.items[tr.Count-1]) do r:=PBuf(@(p^[cn*2])); r:=PBuf(@(p^[GetCount(r)])); Result:=r; end;

function TNtxRO.GetString(p:PBuf;c:SmallInt):ShortString;
var i:integer;
r:ShortString; begin r:='';
if c=0 then c:=ksz; for i:=0 to c-1 do r:=r+chr(p^[8+i]); if DosFl then r:=DosToWin(r); Result:=r; end;

function TNtxRO.GetLink(p:PBuf):integer;
var i,r:integer;
begin r:=0;
for i:=3 downto 0 do r:=r*256+p^[i]; Result:=r; end;

function TNtxRO.GetRecN(p:PBuf):integer;
var i,r:integer;
begin r:=0;
for i:=3 downto 0 do r:=r*256+p^[i+4]; Result:=r; end;

function TNtxRO.GetCount(p:PBuf):Word;
begin
Result:=p^[1]*256+p^[0]; end;

function TNtxRO.Seek(const s:ShortString;fl:boolean):boolean;
var r:boolean;
p,q:PBuf; nx:integer; begin r:=False;
with TTraceRec(tr.items[tr.Count-1]) do begin p:=GetPage(h,pg); while cn<=GetCount(p)+1 do begin q:=GetItem(p); if (cn>GetCount(p))or(s<GetString(q,length(s))) or (fl and (s=GetString(q,length(s)))) then begin nx:=GetLink(q); if nx<>0 then begin Load(nx); r:=Seek(s,fl); end; Result:=r or (s=GetString(q,length(s))); exit; end; Inc(cn); end; end; Result:=False; end;

function TNtxRO.Find(const s:ShortString):boolean;
var r:boolean;
begin
if
h<=0 then begin Result:=False; exit; end; rc:=0; csize:=0; r:=False; while Changed do begin Clear; Load(GetRoot); if length(s)>10 then fs:=Copy(s,1,10) else fs:=s; R:=Seek(s,True); end; Result:=r; end;

function TNtxRO.Load(N:integer):PBuf;
var it:TTraceRec;
r:PBuf; begin r:=nil;
if h>0 then begin with tr do begin it:=TTraceRec.Create(N,1); Add(it); end; r:=GetPage(h,N); end; Result:=r; end;

procedure TNtxRO.Clear;
var it:TTraceRec;
begin
while
tr.Count>0 do begin it:=TTraceRec(tr.Items[0]); tr.Delete(0); it.Free; end; end;

function TNtxRO.Pop:PBuf;
var r:PBuf;
it:TTraceRec; begin r:=nil;
with tr do if Count>1 then begin it:=TTraceRec(Items[Count-1]); Delete(Count-1); it.Free; it:=TTraceRec(Items[Count-1]); r:=GetPage(h,it.pg) end; Result:=r; end;

function TNtxRO.Changed:boolean;
var i:integer;
r:boolean; begin r:=False;
if h>0 then begin i:=GetEmpty; if i<>empty then r:=True; empty:=i; i:=GetSize; if i<>csize then r:=True; csize:=i; end; Result:=r; end;

constructor TNtxRO.Open(nm:ShortString);
begin
Error:=False; h:=FileOpen(nm,fmOpenRead or fmShareDenyNone); if h>0 then begin fs:=''; FileSeek(h,12,0); FileRead(h,isz,2); FileSeek(h,14,0); FileRead(h,ksz,2); FileSeek(h,18,0); FileRead(h,max,2); FileSeek(h,20,0); FileRead(h,hlf,2); empty:=-1; csize:=-1; DosFl:=True; tr:=TList.Create; end else Error:=True; end;

destructor TNtxRO.Destroy;
begin
if
h>0 then begin FileClose(h); Clear; tr.Free; FreeHandle(h); end; inherited Destroy; end;

function TNtxRO.GetRoot:integer;
var r:integer;
begin r:=-1;
if h>0 then begin FileSeek(h,4,0); FileRead(h,r,4); end; Result:=r; end;

function TNtxRO.GetEmpty:integer;
var r:integer;
begin r:=-1;
if h>0 then begin FileSeek(h,8,0); FileRead(h,r,4); end; Result:=r; end;

function TNtxRO.GetSize:integer;
var r:integer;
begin r:=0;
if h>0 then r:=FileSeek(h,0,2); Result:=r; end;

constructor TTraceRec.Create(p:integer;c:SmallInt);
begin
pg:=p; cn:=c; end;

function GetPage(h,fs:integer):PBuf; {Протестировать отдельно}
var i,j,mn:integer;
q:PBuf; begin
mn:=10000; j:=0; for i:=1 to MaxPgs do if (Cache[i].Handle=h)  and (Cache[i].Offset=fs) then begin j:=i; if Cache[i].Countr<10000 then Inc(Cache[i].Countr); end; if j=0 then begin for i:=1 to MaxPgs do if Cache[i].Handle=0 then j:=i; if j=0 then for i:=1 to MaxPgs do if Cache[i].Countr<=mn then begin mn:=Cache[i].Countr; j:=i; end; Cache[j].Countr:=0; mn:=0; end; q:=PBuf(@(Buf[(j-1)*1024+1])); if mn=0 then begin FileSeek(h,fs,0); Cache[j].Length:=FileRead(h,q^,1024); end; Cache[j].Handle:=h; Cache[j].Offset:=fs; Result:=q; end;

procedure FreeHandle(h:integer);
var i:integer;
begin
for
i:=1 to MaxPgs do if Cache[i].Handle=h then Cache[i].Handle:=0; end;

function DosToWin(const ss:ShortString):ShortString;
var r:ShortString;
i:integer; begin r:='';
for i:=1 to length(ss) do if ss[i] in [chr($80)..chr($9F)] then r:=r+chr(ord(ss[i])-$80+$C0) else if ss[i] in [chr($A0)..chr($AF)] then r:=r+chr(ord(ss[i])-$A0+$C0) else if ss[i] in [chr($E0)..chr($EF)] then r:=r+chr(ord(ss[i])-$E0+$D0) else if ss[i] in [chr($61)..chr($7A)] then r:=r+chr(ord(ss[i])-$61+$41) else if ss[i] in [chr($F0)..chr($F1)] then r:=r+chr($C5) else r:=r+ss[i]; Result:=r; end;
function WinToDos(const ss:ShortString):ShortString;
var r:ShortString;
i:integer; begin r:='';
for i:=1 to length(ss) do if ss[i] in [chr($C0)..chr($DF)] then r:=r+chr(ord(ss[i])-$C0+$80) else if ss[i] in [chr($E0)..chr($FF)] then r:=r+chr(ord(ss[i])-$E0+$80) else if ss[i] in [chr($F0)..chr($FF)] then r:=r+chr(ord(ss[i])-$F0+$90) else if ss[i] in [chr($61)..chr($7A)] then r:=r+chr(ord(ss[i])-$61+$41) else if ss[i] in [chr($D5), chr($C5)] then r:=r+chr($F0) else r:=r+ss[i]; Result:=r; end;

end.

[000975]



Содержание раздела