Здравствуйте, angel.nero.
Вот в приложении код программы, которая решает Ваше задание. Плохо, что Вы не отвечали на мои уточняющие вопросы. Поэтому сделал так, как понял.
Что непонятно или не так сделано - пишите. Покумекаем и исправим
А также исходный код, доступный для скачивания:
исходный кодИ самое главное: программа написана в Borland Pascal в д..рацком ABCpascal работать не будет - там не поддерживаются типизированные файлы. По крайней мере, в той версии, которая есть у меняПриложение:
uses CRT;
const
len_street = 10;
len_house = 5;
Type
OneInfo = record
Street: String[len_street];
House : String[len_house]; {Может быть кроме номера еще и корпус: а, б ...}
Room : Integer;
Level : Integer;
end;
CONST
max_Infos = 100;
dat_fileName = '177587.dat'; {Файл для хранения записей}
VAR
{Для хранения используем массив фиксированной длины в 100 записей}
Info: Array[1..max_Infos] of OneInfo;
Streets: Array[1..max_Infos] of OneInfo;
count: Integer; {Число записей в базе данных}
count_streetS: Integer; {Число улиц}
changed: Boolean; {были ли изменения списка}
function UpRuss(s: String): String;
{Преобразование строки в состоящую из заглавных букв.
Нужна для правильного сравнения}
var i, len: Integer;
begin
len := length(s);
for i:=1 to len do
Case s[i] of
'a'..'z': s[i] := UpCase(s[i]);
'а'..'п': s[i] := chr(ord(s[i]) - 32);
'р'..'я': s[i] := chr(ord(s[i]) - 80);
end;
UpRuss := s
end;
procedure ReadFromFile;
var
f : file of OneInfo;
c : Integer;
o : OneInfo;
begin
Assign(f, dat_fileName);
{$I-} Reset(f); {$I+}
if IOResult <> 0 then begin
WriteLn('Считывание информации невозможно: файл ',dat_fileName,' не найден');
WriteLn(' Нажмите любую клавишу');
ReadKey;
Exit; {Немедленный вывход из подпрограммы}
end;
WriteLn('Добавление информации из файла ', dat_fileName);
if count = max_Infos then
WriteLn('Список полон - нельзя добавить информацию')
else
begin
c:= 0;
while (c + count + 1< max_Infos) and (NOT EOF(f)) do
begin
Read(f, Info[c + count + 1]);
inc(c);
end;
WriteLn('Добавлено записей: ',c);
if count <> 0 then changed := True;
count := count + c;
end;
WriteLn(' Нажмите любую клавишу');
ReadKey;
Close(f);
end;
procedure SaveToFile;
{сохранение списка в файл}
var
f: file of OneInfo;
i: Integer;
begin
if count = 0 then
WriteLn('Списк пуст, нечего сохранять')
else
begin
WriteLn('Сохранение информации в файл');
Assign(f, dat_fileName);
{Сначала проверим, есть ли такой}
{$I-} Reset(f); {$I+}
if IOResult = 0 then
begin
Close(f);
WriteLn('Файл с именем ',dat_fileName,' уже имеется');
WriteLn('Если не хотите изменить файл, нажмите 1');
WriteLn(' После нажатия любой друго клавиши старая информаиця дудет удалена');
if ReadKey = '1' then
Exit; {Немедленный выход ничего не делая}
{В принципе, можно и дописать в конец, но тут возможна
ситация, когда запишешь больше чем сможешь прочиитать
(количество считываемого ограничено)}
end;
Rewrite(f);
for i:=1 to count do
Write(f, Info[i]);
Close(f);
WriteLn('Добавлено записей: ', count)
end;
changed := false;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure Print(no: Integer);
{Вывод одной записи с заданным номером}
begin
if (no > 0) and (no <= count) then {элементарная проверка}
WriteLn(no:4,') ', Info[no].Street:len_street,' ',
Info[no].House:len_house,' ',
Info[no].Room:5,' ',Info[no].Level:5);
end;
procedure Print1;
{Вывод всего списка}
var i: integer;
begin
if count =0 then
WriteLn('Список пуст')
else
begin
WriteLn('номер Улица дом квартира этаж');
for i:=1 to count do Print(i);
end;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure Enter;
{Заполнение массива}
var c: Integer;
s: String;
begin
ClrScr;
c := 0;
WriteLn('Заполнение массива. Для завершения введите пустое название улицы');
while ( c + count < 100) do begin
Write('Введите название улицы: '); ReadLn(s);
if s = '' then Break; {Немедленный выход из цикла}
inc(c);
Info[count + c].Street := Copy(s, 1, len_street);
{Не более len_street букв в названии}
Write('Введите номер дома: '); ReadLn(s);
Info[count + c].House := Copy(s, 1, len_house);
Write('Введите номер квартиры: ');
ReadLn(Info[count+ c].Room);
Write('Введите этаж: ');
ReadLn(Info[count + c].Level);
WriteLn;
end;
count := count + c;
WriteLn('Добавлено новых записей: ',c,'. Всего в списке записей: ', count);
changed := true;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure MaxRoomNumber;
{Поиск квартиры с наибольшим номером}
var
i, max_no, max_no_count: Integer;
begin
if count = 0 then
WriteLn('Список пуст')
else
begin
max_no := 1;
max_no_count := 1; {число квартир с наибольшим. По крайней мере одна есть}
for i:= 2 to count do
if Info[i].Room > Info[max_no].Room then
begin
max_no_count := 1;
max_no := i
end
else
if Info[i].Room = Info[max_no].Room then
inc(max_no_count);
end;
WriteLn('Максимальный номер квартиры: ',Info[max_no].Room,
' Количество квартир с таким номером: ', max_no_count);
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure FirstLevelPopulation;
var
i, population: Word;
begin
if count = 0 then
WriteLn('Список пуст')
else
begin
population := 0;
for i:=1 to count do
if Info[i].Level = 1 then inc(population);
if population = 0 then
WriteLn('На первом этаже никто не живет')
else
WriteLn('Количество квартир на первом этаже: ', population);
end;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure DoStreet;
var
newStreet: String;
i: Integer;
begin
if count = 0 then
WriteLn('Список пуст')
else
begin
Write('Введите название улицы: '); ReadLn(newStreet);
newStreet := Copy(newStreet, 1, len_street);
count_streets := 0;
for i:=1 to count do
if UpRuss(Info[i].Street) = UpRuss(newStreet) then
begin
inc(count_streets);
Streets[count_streets] := Info[i];
end;
if count_streets = 0 then
WriteLn('Такой улицы ',newStreet,' нет в списке')
else
begin
WriteLn('Список адресов на улице ', newStreet);
for i:=1 to count_streets do
WriteLn(i:3,') ', Streets[i].Street:len_Street,' ',
Streets[i].House:len_house,' ',
Streets[i].Room:5,' ', Streets[i].Level:5);
end;
end;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure Sort;
var
temp: OneInfo;
i, j, min_no: Integer;
{термин "одна процедура сортировки по каждому" понимаю как сортировка
сначала по первому,
потом при равных первых полях по второму полю и т.д.
По четвертому полю сортировать бесполезно - просто глупость одна квартира на
нескольких этажах. Бывают многоэтажные, но адрес у них один - я так думаю.
Если не так нужно, напишите}
begin
if count = 0 then WriteLn('Список пуст')
else
begin
WriteLn('Сортировка массива');
Write('По первому полю');
{Сначала все по первому полю}
for i:=1 to count-1 do
for j := i+1 to count do
if UpRuss(Info[i].Street) > UpRuss(Info[j].Street) then
{UpRuss, чтоб сортировать без учета регистра
Сотрировка - пузырьковая}
begin
temp := Info[i];
Info[i]:= Info[j];
Info[j]:= temp
end;
WriteLn(' закончена');
Write('По второму полю ');
{Теперь по второму полю - сортировка вставкой}
i:=1;
while i < count do
begin
if UpRuss(Info[i].Street) = UpRuss(Info[i+1].Street) then
{если ли вообще равные по первому}
begin
{ищем среди равных по первому полю минимальный
по второму полю}
j:=i+1;
min_no := i;
while UpRuss(Info[i].Street) = UpRuss(Info[j].Street) do
begin
if UpRuss(Info[j].House) < UpRuss(Info[min_no].House) then
min_no := j;
inc(j)
end;
{Нашли минимальный вставили}
if min_no <> i then
begin
temp := Info[i];
Info[i] := Info[min_no];
Info[min_no] := temp
end;
end;
inc(i) {здесь можно немного оптимизировать - если надо, то помогу}
end;
WriteLn(' закончена');
{Проход по третьему полю}
Write('Сортировка по третьему полю');
i :=1;
while i < count do
begin
if (UpRuss(Info[i].Street) = UpRuss(Info[i+1].Street))
and (UpRuss(Info[i].House) = UpRuss(Info[i+1].House)) then
{если ли вообще равные по первому, второму?}
begin
{Опять метод вставки}
j:=i+1;
min_no := i;
while (UpRuss(Info[i].Street) = UpRuss(Info[j].Street))
and (UpRuss(Info[i].House) = UpRuss(Info[i+1].House)) do
begin
if Info[j].Room < Info[min_no].Room then
min_no := j;
inc(j)
end;
if min_no <> i then
begin
temp := Info[i];
Info[i] := Info[min_no];
Info[min_no] := temp
end;
end;
inc(i)
end;
WriteLn(' закончена');
end;
WriteLn(' Для продолжения работы нажмите любую клавишу');
ReadKey
end;
procedure Menu;
var selection: Char;
begin
repeat
ClrScr;
WriteLn('Выберите действие:');
WriteLn(' 1 - Вывод всего списка');
WriteLn(' 2 - Ввод (добавление) инфомации');
WriteLn(' 3 - Очистка базы');
WriteLn(' 4 - Поиск наибольшего номера квартиры');
WriteLn(' 5 - Количество жителей первого этажа');
WriteLn(' 6 - Сформировать список для улицы');
WriteLn(' 7 - Сортировать список');
WriteLn(' 8 - Сохранить список в файл');
WriteLn(' 9 - Ввести информацию из файла');
WriteLn(' 0 - Выход (окончание работы)');
WriteLn;
WriteLn('Информация: в списке ',count,' записей');
selection:=ReadKey;
case selection of
'1': Print1;
'2': Enter;
'3': count := 0;
'4': MaxRoomNumber;
'5': FirstLevelPopulation;
'6': DoStreet;
'7': Sort;
'8': SaveToFile;
'9': ReadFromFile;
'0', #27: Exit; {Дополнительное прекращение работы по нажатию Esc}
end
until selection = '0';
end;
BEGIN
count := 0;
count_streetS := 0;
changed := False;
Menu;
if changed then begin
WriteLn('Список изменен. Сохранить в файл? (Y/N)');
Case ReadKey of
'Y','y','Н','н', #13: SaveToFile;
{и Enter}
end;
end;
END.