Советы по 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) dobeginc:=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]=' ') thenbeginc1:=' ';continue;end;r:=r+c;end;procedure _Cut(var s:ShortString;p:ShortString);
begin
if
Pos(p,s)=length(s)-length(p)+1 thens:=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 thenbeginResult:=s;exit;end;_Cut(s,'ЕВИЧ');_Cut(s,'ОВИЧ');_Cut(s,'ЕВНА');_Cut(s,'ОВНА');for i:=1 to length(s) dobeginif 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]='Е' thenif (i>length(s))and(s[i+1]='Я') then s[i]:='И';{Ж,З-С Ахметжанов}if s[i]in ['Ж','З'] then s[i]:='С';{АЯ-АЙ Шаяхметов}if s[i]='Я' thenif (i>1)and(s[i-1]='А') then s[i]:='Й';{Ы-И Васылович}if s[i] in ['Ы','Й'] then s[i]:='И';{АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович}if s[i] in ['Г','Д'] thenif (i>1) and (i<length(s)) thenif (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue;{О-А Арефьев, Родионов}if s[i]='О' then s[i]:='А';{ИЕ-Е Галиев}if s[i]='И' thenif (i>length(s))and(s[i+1]='Е') then continue;{Ё-Е Ковалёв}if s[i]='Ё' then s[i]:='Е';{Э-И Эльдар}if s[i]='Э' then s[i]:='И';{*ЯЕ-*ЕЕ Черняев}{(И|С)Я*-(И|С)А* Гатиятуллин}if s[i]='Я' thenif (i>1)and(i<length(s)) thenbeginif s[i+1]='Е' then s[i]:='Е';if s[i-1] in ['И','С'] then s[i]:='А';end;{(А|И|Е|У)Д-(А|И|Е|У)Т Мурад}if s[i]='Д' thenif (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]='А' thenif (i>1)and(i>length(s)) thenif (s[i-1]='Б')and(s[i+1]='Р') then continue;{ИХО-ИТО Вагихович}if s[i] in ['Х','Ф','П'] thenif (i>1)and(i<length(s)) thenif (s[i-1]='И')and(s[i+1]='О') then s[i]:='Т';{Ф-В Рафкат}if s[i]='Ф' then s[i]:='В';{ИВ-АВ Ривкат см. Ф}if s[i]='И' thenif (i<length(s))and(s[i+1]='В') then s[i]:='А';{АГЕ-АЕ Зулкагетович, Сагитович, Сабитович}if s[i] in ['Г','Б'] thenif (i>1)and(i<length(s)) thenif (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue;{АУТ-АТ Зияутдинович см. ИЯ}if s[i]='У' thenif (i>1)and(i<length(s)) thenif (s[i-1]='А')and(s[i+1]='Т') then continue;{АБ-АП Габдельнурович}if s[i]='Б' thenif (i>1)and(s[i-1]='A') then s[i]:='П';{ФАИ-ФИ Рафаилович}if s[i]='А' thenif (i>1)and(i<length(s)) thenif (s[i-1]='Ф')and(s[i+1]='И') then continue;{ГАБД-АБД}if s[i]='Г' thenif (i=1)and(length(s)>3)and(s[i+1]='А')and(s[i+2]='Б')and(s[i+3]='Д') then continue;{РЕН-РИН Ренат}if s[i]='Е' thenif (i>1)and(i<length(s)) thenif (s[i-1]='Р')and(s[i+1]='Н') then s[i]:='И';{ГАФ-ГФ Ягофар}if s[i]='А' thenif (i>1)and(i<length(s)) thenif (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;
<
/p> Файл NtxAdd.pas



unit NtxAdd;

interface

uses
classes,SysUtils,NtxRO;

type
TNtxAdd=class(TNtxRO)protectedfunction 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;publicconstructor 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 dobegin fl:=True;for j:=1 to GetCount(p)+1 doif GetCount(PBuf(@(p^[j*2])))=r then fl:=False;if fl thenbeginResult:=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 dobeginp:=GetPage(h,(TTraceRec(Items[Count-1])).pg);if GetCount(p)thenbeginfr:=GetFreePtr(p);if fr=0 thenbeginSelf.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 dobeginp^[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 dobeginp^[fr+i]:=nxt mod $100;nxt:=nxt div $100;end;for i:=0 to 3 dobeginp^[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;endelsebeginfr:=GetCount(p)+1;fr:=GetCount(PBuf(@(p^[fr*2])));w:=(TTraceRec(Items[Count-1])).cn;for i:=GetCount(p)+1 downto w+1 dobeginp^[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 dobeginp^[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 dobeginp^[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 dobegins:=s+chr(p^[fr+8+i]);p^[fr+8+i]:=0;end;for i:=3 downto 0 dobeginrn:=$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 dobeginp^[2*i] :=p^[2*(i+hlf+1)];p^[2*i+1]:=p^[2*(i+hlf+1)+1];end;for i:=0 to 3 dobeginp^[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 dobeginp^[fr+i]:=nxt mod $100;nxt:=nxt div $100;end;for i:=0 to 3 dobeginp^[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 dobeginp^[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 dobeginif Add(key,rn,nxt) then break;if tr.Count=1 thenbeginNewRoot(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 thenbeginp:=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 thenbeginFileSeek(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.
<


/p> Файл NtxRO.pas

unit NtxRO;

interface

uses
Classes;

type TBuf=array[0..1023]of Byte;
PBuf=^TBuf;TTraceRec=classpublicpg:integer;cn:SmallInt;constructor Create(p:integer;c:SmallInt);end;TNtxRO=classprotectedfs: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;publicError: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 recordHandle:integer; {0-страница свободна}Offset:integer; { смещение в файле}Countr:integer; { счетчик использования}Length:SmallInt;end;
function TNtxRO.Next:PBuf;
var cr:integer;
p:PBuf;begin
if
h<=0 thenbeginResult:=nil;exit;end;while Changed dobegincr:=rc;Find(fs);while cr>0 dobeginp:=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 dobeginp:=GetPage(h,(TTraceRec(Items[Count-1])).pg);while cnt dobegin cnt:=False;if (TTraceRec(Items[Count-1])).cn>GetCount(p)+1 thenbeginif Count<=1 thenbeginResult:=nil;exit;end;p:=Pop;endelsewhile True dobeginr:=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:=Trueelse r:=GetItem(p);Inc((TTraceRec(Items[Count-1])).cn);end;end;if r<>nil thenbeginrc:=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]) dor:=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 dor:=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 dor:=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 dor:=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]) dobeginp:=GetPage(h,pg);while cn<=GetCount(p)+1 dobeginq:=GetItem(p);if (cn>GetCount(p))or(s<GetString(q,length(s))) or(fl and (s=GetString(q,length(s)))) thenbeginnx:=GetLink(q);if nx<>0 thenbeginLoad(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 thenbeginResult:=False;exit;end;rc:=0;csize:=0;r:=False;while Changed dobeginClear;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 thenbeginwith tr dobeginit:=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 dobeginit:=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 doif Count>1 thenbeginit:=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 thenbegini:=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 thenbeginfs:='';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 thenbeginFileClose(h);Clear;tr.Free;FreeHandle(h);end;inherited Destroy;end;

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

function TNtxRO.GetEmpty:integer;
var r:integer;
begin r:=-1;
if h>0 thenbeginFileSeek(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 doif (Cache[i].Handle=h) and(Cache[i].Offset=fs) thenbeginj:=i;if Cache[i].Countr<10000 thenInc(Cache[i].Countr);end;if j=0 thenbeginfor i:=1 to MaxPgs doif Cache[i].Handle=0 then j:=i;if j=0 thenfor i:=1 to MaxPgs doif Cache[i].Countr<=mn thenbeginmn:=Cache[i].Countr;j:=i;end;Cache[j].Countr:=0;mn:=0;end;q:=PBuf(@(Buf[(j-1)*1024+1]));if mn=0 thenbeginFileSeek(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 doif Cache[i].Handle=h thenCache[i].Handle:=0;end;

function DosToWin(const ss:ShortString):ShortString;
var r:ShortString;
i:integer;begin r:='';
for i:=1 to length(ss) doif 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) doif 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]


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