Поиск информации по БД в Delphi(консоль)

[Guest]

Здравствуйте! Мне нужна помощь!
Задача:
Создать файл данных. Выбрать одно из полей как ключ поиска.
1. На основе файла создать словарь, состоящий из пар: КЛЮЧ- № записи.
2. Упорядочить словарь по возрастанию ключей.
3. Реализовать поиск данных в файле по ключу с использованием словаря, используя прямой доступ к записям файла
Проблема:
Не могли бы вы, уважаемые форумчане, проверить написанный код, и исправить ошибку, чтобы программа стала работоспособной. Если не сможете по каким-либо обстоятельствам исправить сам код, то, пожалуйста, дайте мне совет по исправлению этой ошибки.

Заранее благодарен!!!

<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">"Неработоспособный код"</div></div><div class="sp-body"><div class="sp-content">program FindMind;

{$APPTYPE CONSOLE}

uses
SysUtils;

type
address = record
name: string[30];
street: string[40];
sity: string[20];
end;
str80 = string[80];
DataItem = address;
DataArray = array [1..80] of DataItem;
recfil = file of DataItem;

var
test: DataItem;
t:integer;
testfile: recfil;

{ найти запись в файле }
function Find(var fp:recfil; i:integer): str80;
var
t:address;
begin
i := i-1;
Seek(fp,i);
Read(fp,t);
Find := t.name;
end;

procedure QsRand(var fp:recfil; count:integer);
procedure Qs(l, r:integer);
var
i, j, s:integer;
x, y, zataItem;
begin
i := l; j := r;
s := (l+r) div 2;
Seek(fp,s-1); { получить запись }
Read(fp,x);
repeat
while Find(fp,i) < x.name do i := i+1;
while x.name < Find(fp, j) do j := j-1;
if i<=j then
begin
Seek(fp,i-1); Read(fp,y);
Seek(fp,j-1); Read(fp,z);
Seek(fp,j-1); Write(fp,y);
Seek(fp,i-1); Write(fp,z);
i := i+1; j := j-1;
end;
until r>l;
if l<j then qs(l, j);
if l<r then qs(i, r);
end;
begin
qs(1,count);
end; { конец быстрой сортировки файла произвольного
доступа }
begin
AssignFile(testfile, 'D:\file.txt');
Reset(testfile);
t := 1;
while not EOF(testfile) do begin
Read(testfile,test); { подсчет числа записей в
файле}
t := t+1;
end;
t := t-1;

QsRand(testfile,t)
end.

 

[SNike]

Код смотреть, честно говоря, лениво. А чего за ошибка выходит? Что и как не работает?

 

[Guest]

Спасибо большое за отзыв, но я уже решил проблему. Сейчас постараюсь оформить для тех кому вдруг понадобится, так же там реализован линейный поиск.

<!--shcode--><pre><code class='grey'>program Search;
uses crt;
label 10;
type
address = record
year: string[4];
surname: string[20];
summa: integer;
end;
str80 = string[80];
DataItem = address;
DataArray = array [1..80] of DataItem;
recfil = file of DataItem;
var
test: DataItem;
t, t2, z:integer;
testfile,fp: recfil;
key: string;

Procedure Sozd (var fp:recfil);
Var i,j:integer;
zk:address;
begin
rewrite (fp);
j:=1;
while j<>0 do
begin
write ('vvedite god: ');
readln (zk.year);
write ('Vvedite familiyu: ');
readln (zk.surname);
write ('Vvedite summu: ');
readln (zk.summa);
write (fp,zk);
writeln ('Esli konec zapisi to nazhmite 0 ');
readln (j);
end;
close (fp);
end;

Procedure vyvod (var fp:recfil);
Var i:integer;
zk:address;
begin
reset (fp);
writeln ('=========================');
writeln ('| god | familiya | summa');
writeln ('=========================');
while not eof(fp) do
begin
read (fp,zk);
write ('|',zk.year:6);
write (' |',zk.surname:13);
write (' |',zk.summa:6);
writeln;
writeln ('-------------------------');
end;
close (fp);
end;

Procedure poisk_lineyniy (var fp:recfil);
var i:integer;
zk:address;
begin
reset (fp);
write ('Vvedite god dlja poiska: ');
readln (key);
writeln ('spisok s zadannym godom ');
writeln ('=========================');
writeln ('| god | familiya | summa');
writeln ('=========================');
while not eof(fp) do
begin
read (fp,zk);
if zk.year = key then
begin
write ('|',zk.year:6);
write (' |',zk.surname:13);
write (' |',zk.summa:6);
writeln;
writeln ('--------------------------');
end;
end;
close(fp);
end;

function Find(var fp:recfil; i:integer): str80;
var
t:address;
begin
i := i-1;
Seek(fp, i);
Read(fp, t);
Find := t.year;
end;

procedure bin(n,k:integer);
Var mid:integer;
zk:address;
Begin
mid:=(k+n) div 2;
seek(fp,mid);
Read(fp,zk);
If k > n Then
begin
if key > zk.year then bin(mid,k);
if key < zk.year then bin(n,mid)
else
begin
write ('|',zk.year:6);
write (' |',zk.surname:13);
write (' |',zk.summa:6);
writeln;
writeln ('--------------------------');
exit;
end
end
else writeln('takoy zapisi net!');
end;

procedure QsRand(var fp:recfil; count:integer);
procedure Qs(l, r:integer);
var
i, j, s:integer;
x, y, zataItem;
begin
i := l; j := r;
s := (l+r) div 2;
Seek(fp,s-1);
Read(fp,x);
repeat
while Find(fp, i) < x.year do i := i+1;
while x.year < Find(fp, j) do j := j-1;
if i<=j then
begin
Seek(fp,i-1); Read(fp,y);
Seek(fp,j-1); Read(fp,z);
Seek(fp,j-1); Write(fp,y);
Seek(fp,i-1); Write(fp,z);
i := i+1; j := j-1;
end;
until i>j;
if l<j then qs(l, j);
if l<r then qs(i, r);
end;
begin
qs(1,count);
bin(1,count);
end;

BEGIN
clrscr;
10:
assign(fp,'spisok_klientov.txt');
writeln (' BAZA DANNIH ');
writeln ('1:sozdanie');
writeln ('2:vivod');
writeln ('3oisk lineyniy');
writeln ('4oisk binarniy');
writeln ('5:vyhod');
writeln;
write ('Vvedite komandu: ');
readln (z);
case z of
1:sozd(fp);
2:vyvod (fp);
3oisk_lineyniy (fp);
4:begin
write ('Vvedite god dlja poiska: ');
readln (key);
writeln ('spisok s zadannym godom ');
writeln ('=========================');
writeln ('| god | familiya | summa');
writeln ('=========================');
t := 0;
reset(fp);
while not EOF(fp) do
begin
Read(fp,test);
t := t+1;
end;
QsRand(fp,t)
end;
5:exit;
end; goto 10;
readln
END.[/CODE]
До скорой встречи!!!

 

[SNike]

Молодца! А то я только твой прежний код стал уже пересматривать :RTFM:
Приятно иметь дело с людьми которые сами что-то стараются сделать!