Работа с индексами 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]
