var

I, J: Integer;

D: Integer;

R: Integer;

begin

randomize;

for I:=1 to N do

for J:=1 to M do

begin

Присваеваем элементу любое значение от 0 до 99.

A[I,J]:=random(100);

Если случайное число от 0 до 999 четное, данный элемент становится отрицательным, иначе знак не изменяется.

if (random(1000) mod 2)=0 then

A[I,J]:=0-A[I,J];

end;

end;

Процедура вывода матрицы на экран.

procedure PrintMatrix(var A: Matrix; N, M: Integer);

var

I, J: Integer;

Begin

Задаем два цикла, один для столбцов, второй для строк и поочередно выводим все элементы строки. После чего выводим следующую строку.

for I:=1 to N do

begin

for J:=1 to M do

write(A[I,J]:4);

writeln;

end;

end;

Процедура поворота матрицы на 90 градусов направо.

procedure TurnMatrix(var A: Matrix; N: Integer);

var

Arr: Vector;

I, J, K, Ot, L: Integer;

R: Integer;

Revers: Integer;

Buf1, Buf2: Integer;

begin

R:=N div 2;

Ставим начальное значение отступа Ot равным нулю.

Ot:=0;

for K:=1 to R do

begin

Переменная L отвечает за колличество экллементов в массиве Arr. Ставим начально значение равное нулю, а затем заносим в массив Arr элементы матрицы.

L:=0;

for J:=1+Ot to N-Ot do

begin

Inc(L);

Arr[L]:=A[1+Ot, J];

end;

for I:=2+Ot to N-1-Ot do

begin

Inc(L);

Arr[L]:=A[I, N-Ot];

end;

for J:=N-Ot downto 1+Ot do

begin

Inc(L);

Arr[L]:=A[N-Ot, J];

end;

for I:=N-1-Ot downto 2+Ot do

begin

Inc(L);

Arr[L]:=A[I, 1+Ot];

end;

Находим на сколько элементов нужно сдвинуть массив Arr.

Revers:=N-2*Ot-1;

Далее, с помошью процедуры, циклически сдвигаем массив Arr из L элементов на Revers позиций вправо. И записываем получившийся массив обратно в матрицу.

TurnArray(Arr, L, Revers);

L:=0;

for J:=1+Ot to N-Ot do

begin

Inc(L);

A[1+Ot, J]:=Arr[L];

end;

for I:=2+Ot to N-1-Ot do

begin

Inc(L);

A[I, N-Ot]:=Arr[L];

end;

for J:=N-Ot downto 1+Ot do

begin

Inc(L);

A[N-Ot, J]:=Arr[L];

end;

for I:=N-1-Ot downto 2+Ot do

begin

Inc(L);

A[I, 1+Ot]:=Arr[L];

end;

Увеличиваем значение отступа.

Inc(Ot);

end;

Процедура циклического сдвига массива.

procedure TurnArray(var V: Vector; NN: Integer; Rev: Integer);

var

Buf: Integer;

I, J: Integer;

Begin

for J:=1 to Rev do

begin

Сохраняем значение элемента V[NN] в Buf, а затем сдвигаем элементы массива на 1 позицию.

Buf:=V[NN];

for I:=NN downto 2 do

V[I]:=V[I-1];

V[1]:=Buf;

end;

end;

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

Begin

Выводим на экран меню, представленное на рисунке 2.

Рисунок 2 - главное меню третьей программы.

menu;

Задаем три переменных, которые будут отвечать за информацию о вводе имени для трех файлов. И еще одну, которая будет отвечать за работу программы.

pf:=false;

vf:=false;

tf:=false;

cont:=true;

В будущем нам понадобится еще 2 переменных, flag1 и flag1, которые будут отвечать за наличие информации в файлах.

flag1:=false;

flag2:=false;

while cont do

begin

writeln;

write('Vvedite komandu: ');

Считываем комманду и запускаем одну из процедур.

readln(command);

case command of

'0': cont:=false;

'1': begin

write('Vvedite imja pervogo faila: ');

readln(p);

Запускаем проверку правильности ввода имени файла, и если она проходит, то флаг ввода принимает значение True. Иначе будет выведено сообщение о неправильном вводе.

if check1(p)=true then

begin

pf:=true;

clrscr;

menu;

end

else

begin

clrscr;

menu;

writeln('Error input');

end;

end;

'2': begin

write('Vvedite imja vtorogo faila: ');

readln(v);

Запускаем проверку правильности ввода имени файла, и если она проходит, то флаг ввода принимает значение True. Иначе будет выведено сообщение о неправильном вводе.

if check1(v)=true then

begin;

vf:=true;

clrscr;

menu;

end

else

begin

clrscr;

menu;

writeln('Error input');

end;

end;

'3': begin

write('Vvedite imja tretego faila: ');

readln(t);

Запускаем проверку правильности ввода имени файла, и если она проходит, то флаг ввода принимает значение True. Иначе будет выведено сообщение о неправильном вводе.

if check1(t)=true then

begin

tf:=true;

clrscr;

menu;

end

else

begin

clrscr;

menu;

writeln('Error input');

end;

end;

'4': begin

Если все три имени файла введены верно, то запускается ряд процедур по составлению третьего файла.

if (pf=true)and(vf=true)and(tf=true) then

begin

filepr;

Данная процедура смотрит колличество строк в файлах и выбирает максимальное и минимальное.

chmax;

Если оба файлы не пустые, то программа приступает к образованием слов и записи их в третий файл.

if check2=false then

begin

Ставим цикл до минимального числа строк.

for l:=1 to m do

begin

slv;

obrslov(slova1,slova2,k1,k2,slova,k);

for g:=1 to k do

begin

write(third,slova[g]);

if g<k then write(third,' ');

end;

Здесь осуществляется переход на следующую строчку.

writeln(third,'');

end;

Выбираем в каком из файлов больше строк и переписываем оставшиеся без изменений.

if m1<>m2 then

begin

if m1>m2 then for L:=m to m1 do

begin

readln(first,S1);

writeln(third,S1);

end

else

for L:=m to m2 do

begin

readln(second,S2);

Writeln(third,S2);

end;

end;

closing;

writeln('Operacia zavershena');

end

else

Если первые два файла не прошли проверку, то программа скажет, какой именно из файлов пустой.

begin

if flag1=true then writeln('Pervii fail pustoi');

if flag2=true then writeln('Vtoroi fail pustoi');

end;

end

else

begin

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

if pf=false then writeln('Ne vvedeno imja pervogo faila');

if vf=false then writeln('Ne vvedeno imja vtorogo faila');

if tf=false then writeln('Ne vvedeno imja tretego faila');

end;

end;

else

writeln('Neizvestnaya komanda');

end;

end;

end.

Процедура правильности проверки ввода имени файлов.

function check1(x:string):boolean;

begin

В данном случае проверяется пустой ввод, и имя файла, начинающееся с пробела.

if length(x)>0 then begin

if x[1]<>' ' then

check1:=true;

end;

end;

Процедура привязки и открытия файлов.

procedure filepr;

begin

assign(first,p);

assign(second,v);

assign(third,t);

reset(first);

reset(second);

rewrite(third);

end;

Процедура проверки колличества строк в файлах.

procedure chmax;

begin

Сбрасываем счетчик строк.

m1:=0;

m2:=0;

И пока не конец файла перебираем строки и прибавляем по еденице к счетчику.

while not eof(first) do

begin

readln(first,S1);

m1:=m1+1;

end;

Пока не конец файла перебираем строки и прибавляем по еденице к счетчику.

while not eof(second) do

Begin

readln(second,S2);

m2:=m2+1;

end;

И присваиваем минимальное значение для переменной m.

if m1<m2 then m:=m1 else m:=m2;

Заново закрываем и открываем файлы.

close(first);

reset(first);

close(second);

reset(second);

end;

Процедура разбития строки на слова и перемещение их в массив.

Procedure slv;

var

i,j:integer;

begin

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

Readln(first,S1);

readln(second,S2);

S1:=' '+S1+' ';

S2:=' '+S2+' ';

Сбрасываем счетчик колличества слов.

k1:=0;

k2:=0;

Начинаем перебор элементов до тех пор, пока не найдем пробел. Далее смотрим, если след элемент после пробела, тоже пробел, то пропускаем первый. Если же мы получаем слово, то копируем его в одну из ячеек массива.

for i:=1 to length(S1) do

begin

if s1[i]=' ' then

begin

for j:=i+1 to length(s1) do

if s1[i+1]<>' ' then

if s1[j]=' ' then begin

k1:=k1+1;

slova1[k1]:=copy(s1,i+1,j-i-1);

break;

end;

end;

end;

for i:=1 to length(S2) do

begin

if s2[i]=' ' then

begin

for j:=i+1 to length(s2) do

if s2[i+1]<>' ' then

if s2[j]=' ' then begin

k2:=k2+1;

slova2[k2]:=copy(s2,i+1,j-i-1);

break;

end;

end;

end;

end;

Процедура отсортировки слов.

procedure obrslov(a,b:arr;na,nb:integer; var c:arr; var nc:integer);

var i,j,k:integer;

Страницы: 1, 2, 3, 4, 5