{$I KEYS} unit Indextrd; interface procedure IndAddName (var s :string; A :pointer); function IndFindName(var s :string) :pointer; function UnloadInd (u :boolean) :longint; implementation type pItype = ^Itype; Itype = record A :pointer; Next :pItype; Other :pItype; C :char; end; var IndexI :pItype; var UnloSumma :longint; procedure EraseI(var p :pItype; u :boolean); begin if p <> nil then begin EraseI(p^.Next, u); EraseI(p^.Other, u); UnloSumma:=UnloSumma + sizeof(p^); if u then begin dispose(p); p:=nil; end; end; end; function FindOther(C :char; p :pItype) :pItype; label Ex; begin FindOther:=nil; while p <> nil do begin if p^.C = C then begin FindOther:=p; goto Ex end; p:=p^.Other end; Ex: end; function MakeNext :pItype; var q :pItype; begin new(q); q^.C:='^'; q^.A:=nil; q^.Next:=nil; q^.Other:=nil; MakeNext:=q; end; function UnloadInd(u :boolean) :longint; begin UnloSumma:=0; EraseI(IndexI, u); UnloadInd:=UnloSumma; end; procedure IndAddName(var s :string; A :pointer); var p,q :pItype; pU :^pItype; i,L :integer; begin p:=IndexI; pU:=@IndexI; L:=length(s); for i:=1 to L do begin q:=FindOther(s[i],p); if q = nil then begin new(q); q^.C:=s[i]; q^.A:=nil; q^.Next :=MakeNext; q^.Other:=p; pU^:=q; end; if i=L then q^.A:=A; p:=q^.Next; pU:=@q^.Next; end; end; function IndFindName(var s :string) :pointer; label 1,Ex; var i,L :integer; p,q :pItype; c :char; begin IndFindName:=nil; if s <> '' then begin L:=length(s); p:=IndexI; for i:=1 to L do begin {------------------} c:=s[i]; q:=nil; while p <> nil do begin if p^.c = c then begin q:=p; goto 1 end; p:=p^.Other end; 1: (* *); {------------------} if q = nil then goto Ex; p:=q^.Next; end; IndFindName:=q^.A; end; Ex: end; begin IndexI:=nil; end.