Да... думал — раз, и квас, ан нет: задачка заковыристая. И весьма. Ну вот что получилось. Должен, правда, предупредить, что программа написана, отлажена и оттестрована на DOS Free Pascal, а если у Вас, к примеру, этот грёбаный ABC, который начнёт верещать, то я за это не отвечаю. Впрочем, напишите, разберёмся.
Код:
Const
K=20; {Количество посадочных мест в автобусе}
Var
A:Array[1..5,1..7] of Byte; {Число проданных билетов на маршрут, рейс}
W:Array[1..5,1..7] of Byte; {Номера исключаемых рейсов}
i,j:Byte;
Function Rent(M1:Byte {Маршрут}):Boolean; {Рентабельность}
var i1,Num_of_R,Num_of_B:Byte;
begin
Num_of_R:=0; {Количество неотмененных рейсов}
Num_of_B:=0; {Количество проданных билетов}
for i1:=1 to 7 do
if W[M1,i1]=1 then
begin
Inc(Num_of_R);
Inc(Num_of_B,A[M1,i1]);
end;
Rent:=(1.0*Num_of_B>0.75*Num_of_R*K);
end;
Function Min_R(M:Byte):Byte; {номер рейса маршрута M с минимальной загрузкой}
var
Mnt,MnR,q,Rm:Byte;
begin
Mnt:=K;
for q:=1 to 7 do
if (W[M,q]=1) and (A[M,q]<Mnt) then
begin
MnR:=q;
Mnt:=A[M,q];
end;
Min_R:=MnR;
end;
Procedure Crash; {Заполнение массива исключаемых рейсов}
var
m1,r1,t1,i1,j1,Sum:Byte;
begin
for i1:=1 to 5 do
if Rent(i1)=FALSE then
repeat
W[i1,Min_R(i1)]:=0;
Sum:=0;
for j1:=1 to 7 do Inc(Sum,W[i1,j1]);
until Rent(i1) or (Sum=0);
end;
Begin
for i:=1 to 5 do
for j:=1 to 7 do
W[i,j]:=1;
for i:=1 to 5 do
begin
for j:=1 to 7 do
repeat
Write(' Маршрут ',i,' Рейс ',j, ' Продано билетов ');
Readln(A[i,j]);
if A[i,j]>K then Writeln(' Число билетов не может превышать ',K,'!');
until A[i,j]<=K;
Writeln;
end;
Crash;
Writeln(' Отменяются: ');
for i:=1 to 5 do
for j:=1 to 7 do
if W[i,j]=0 then
Writeln(' Маршрут ',i,' Рейс ',j);
Readln;
End.