3                   Задание №3

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

3.1            Блок-схема программы

3.2            Работа программы

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;

begin

nc:=0;

Делаем несколько циклов, среди которых перебираем элементы первого массива и сравниваем их со вторым. Затем элементы вторго с элементами первого и оставшиеся заносятся в новый массив.

for i:=1 to na do

begin

k:=0;

for j:=1 to nb do

if a[i]=b[j] then k:=1;

if k=0 then

begin

nc:=nc+1;

c[nc]:=a[i];

end;

end;

for i:=1 to nb do

begin

k:=0;

for j:=1 to na do

if b[i]=a[j] then k:=1;

if k=0 then

begin

nc:=nc+1;

c[nc]:=b[i];

end;

end;

end;

Функция проверки файлов на информацию.

function check2:boolean;

begin

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

if eof(first)=true then flag1:=true else flag1:=false;

if eof(second)=true then flag2:=true else flag2:=false;

if (flag1=false)and(flag2=false) then check2:=false else check2:=true;

end;

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

procedure closing;

begin

close(first);

close(second);

close(third);

end;

4                   Задание №4.

На экране построить семейство кривых (Гипоциклоида), заданных функцией:

X=A∙cos(t)+D∙cos(A∙t);                    [0<=t<=2∙pi]

X=A∙sin(t)+D∙sin(A∙t);

Группа параметров A,D для построения семейства дана в текстовом файле.

4.1            Работа программы

Begin

Присваиваем начальное значение t, и флаг работы программы.

t:=0;

menu;

cont:=true;

while cont do

begin

Вводим команду в появившееся меню, показанное на рисунке 3.


Рисунок 3 – меню программы 4.
Writeln('Vvedite komady: ');

Readln(command);

case command of

'0':cont:=false;

'1':

begin

writeln;

Вводится имя файла. Имя проходит проверку, если проверка успешна, то из него читаются два значения (А и D) и файл сразу же закрывается.

writeln('Vvedite imja faila: ');

Readln(name);

if check1 = true then begin

namef:=true;

read(fileg,a);

read(fileg,d);

close(fileg);

end else namef:=false;

end;

'2':

Begin

Если из файла успешно считали информацию, программа переходит к построению графика, а именно:

-Очистака окна.

-Изменению разрешения.

-Построению графика.

-Завершению выполнения программы.

if namef=false then

writeln('Ne Vvedeno imja faila')

else

begin

clearwindow;

SetWindowSize(800,600);

mnoj;

graf;

cont:=false;

end;

end;

end;

end;

Следующая функция не дает изменять график до функции ReDraw.

lockdrawing;

OnResize же позволяет делать определенные процедуры при изменение размера окна.

OnResize:=resize;

end.

Функция У

function Yfunc(i: real): real;

begin

result:=A*sin(i)-D*sin(A*t);

end;

Функция Х

function Xfunc(i:real):real;

begin

Xfunc:=A*cos(i)+D*cos(A*i);

end;

Процедура нахождения максимального значения функции, а заодно и множителя.

procedure mnoj;

begin

t:=0;

Задаем цикл и ищем максимальное значение.

while t <= 2*pi do

begin

xx:=trunc(Xfunc(t));

ifabs(xx)> maxx then maxx:=abs(xx);

yy:=trunc(Yfunc(t));

if abs(yy)> maxy then maxy:=abs(yy);

Здесь изменяем точность поиска.

t:=t+0.001;

end;

После чего ищем коэффициент координат. Он зависит от нескольких переменных: ширина, высота, и максимальной координаты.

if WindowWidth<WindowHeight then

if maxy>maxx then k:=(WindowHeight/2)/maxy else k:=(windowWidth/2)/maxx else

If maxx>maxy then k:=(windowheight/2)/maxx else k:=(windowWidth/2)/maxy;

end;

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

function check1:boolean;

begin

Проверка длинны имени файла.

if length(name)>0 then

begin

assign(fileg, name);

reset(fileg);

if eof(fileg)=false then check1:= true else check1:=false;

end;

end;

Процедура построения графика.

procedure graf;

begin

Уменьшаем наш коэффициент, чтобы уместились обозначения системы координат.

k:=k-k*0.1;

Далее чертим ровно по центру оси Х и У. Стрелочки, показывающее направление. Все данные берутся в зависимости от размера экрана, для удобства просмотра как при маленьком, так и при большом разрешение.

moveto(1, windowHeight div 2);

lineto(WindowWidth, WindowHeight div 2);

moveto(WindowWidth div 2, 1);

lineto(WindowWidth div 2, WindowHeight);

moveto(trunc((WindowWidth div 2)*0.98),trunc(0.04*WindowHeight));

Lineto((Windowwidth div 2),1);

lineto(trunc((windowWidth div 2)*1.02),trunc(0.04*windowHeight));

moveto(trunc(windowwidth*0.96),trunc(0.98*(windowheight div 2)));

lineto(windowwidth,windowheight div 2);

lineto(trunc(windowwidth*0.96),trunc(1.02*(windowheight div 2)));

T:=0;

Вычисляем стартовые координаты и перемещаем туда курсор, для дальнейшего построения.

xx:=(WindowWidth div 2)+trunc(k*Xfunc(t));

yy:=(WindowHeight div 2)+trunc(k*Yfunc(t));

moveto(xx,yy);

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

while t<=2*pi do

begin

xx:=(WindowWidth div 2)+trunc(k*Xfunc(t));

yy:=(WindowHeight div 2)+trunc(k*Yfunc(t));

lineto(xx,yy);

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

t:=t+0.001;

end;

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

If WindowWidth>400 then

If Windowheight>200 then

begin

textout(trunc(1.05*(windowWidth div 2)),trunc(0.01*(WindowHeight )),'Y');

Textout(trunc(0.95*WindowWidth),trunc((WindowHeight div 2)*1.05),'X');

end;

end;

Процедура перечерчивания графика при смене разрешения.

procedure resize;

begin

mnoj;

ClearWindow;

graf;

redraw;

lockdrawing;

end;

5                   Задание №5

Написать программу, которая формирует файл записей данной структуры:

Type Vladelez=Record

Familia: String;

Adress:String;

Avto:lnteger;

Nomer:Integer;

End;

и определяет: -количество автомобилей каждой марки;

                    -владельца самого старого автомобиля;

                   -фамилии владельцев и номера автомобилей данной марки.

5.1            Блок-схема программы

5.2            Работа программы

Begin

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

for i:=1 to 200 do

ch[i]:=false;

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


Рисунок 5 – меню пятой программы.
clrscr;

menu;

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

cont:=true;

fzap:=false;

while cont do

begin

write('Vvedite komandu: ');

readln(command);

case command of

'0': cont := false;

'1':

Begin

Задаем общее количество элементов массива, если запись будет соответствовать условию, то fzap присвоится true.

Write('Vvedite kol-vo zapisei(1..200): ');

readln(n);

if (n>0) and (n<=200) then

fzap:=true else fzap:=false;

end;

'2':

Begin

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

if fzap=true then

begin

for i:=1 to n do

сhange(i, avtovl, ch);

clrscr;

menu;

end

else writeln('Ne vvedeno kol-vo zapisei');

end;

'3':

Begin

Если было введено общее количество элементов, то можно редактировать записи по очереди. Если введено число больше общего числа элементов, то программа сообщит от ошибке ввода.

if fzap=true then

begin

write('Vvedite nomer redaktiryemoi zapisi: ');

readln(i);

if i>n then writeln('Wrong input')

else

begin

change(i, avtovl, ch);

clrscr;

menu;

end;

end

else Writeln('Ne vvedeno obshee chislo zapisei');

end;

'4':

Begin

Вначале программа проверяет, введено ли общее число элементов. Затем проверяет каждый элемент по очереди. Если все они заполнены, то начинается выполнятся процедура по подсчету машин каждой марки.

if fzap=true then

begin

for i:=1 to n do

if ch[i]=false then

begin

dzap:=false;

writeln('Vvedeni ne vse zapisi');

end

else dzap:=true;

if dzap=true then

mark(avtovl);

end

else

Writeln('Ne vvedeno obshee chislo zapisei');

end;

'5':

Begin

Все проверки выполняются аналогично предыдущему варианту, но здесь выбирается процедура нахождения хозяина самого старого авто.

if fzap=true then

begin

for i:=1 to n do

if ch[i]=false then

begin

dzap:=false;

writeln('Vvedeni ne vse zapisi');

end

else dzap:=true;

if dzap=true then

mostold(avtovl);

end

else

Writeln('Ne vvedeno obshee chislo zapisei');

end;

'6':

Begin

Все проверки выполняются аналогично предыдущему варианту, но здесь выбирается иная процедура.

if fzap=true then

begin

for i:=1 to n do

if ch[i]=false then

begin

dzap:=false;

writeln('Vvedeni ne vse zapisi');

end

else dzap := true;

if dzap=true then

oprmarki(avtovl);

end

else

Writeln('Ne vvedeno obshee chislo zapisei');

end;

end;

end;

end.

Процедура oprmarki;

procedure oprmarki(x: mas);

var

h:integer;

m:string;

begin

Вводим название марки, и программа переберет все записи и при нахождение такой же марки выведет на экран фамилию владельца и номер автомобиля.

Write('Vvedite marku avto: ');

readln(m);

for h:=1 to n do

if x[h].Avto=m then

writeln(x[h].Familia, ' nomer-', x[h].Nomer);

end;

Процедура нахождения самого старого авто

procedure mostold(x: mas);

var

min,nmin,h:integer;

begin

min:=x[1].Vypusk;

nmin:=0;

Перебираем все записи и сохраняем минимальный год выпуска в переменную min, а номер записи в переменную nmin. А после цикла их выводит на экран.

for h:=1 to n do

if x[h].Vypusk<min then

begin

min:=x[h].Vypusk;

nmin:=h;

end;

Writeln(x[nmin].Familia, ' - ', min,' god vypuska');

end;

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

procedure mark(x: mas);

var

h, l, k: integer;

begin

for h := 1 to n do

begin

Вначале программы задаем пустое множество. И запускаем цикл. Если определенной марки нет в множестве, тогда добавляем ее. И запускаем второй цикл, только начиная не с единицы, а с h-го элемента. Затем если h-ый и l-ый элементы совпадают, прибавляем к счетчику единицу .И в конце второго цикла выводим собранные данные на экран.

if not (x[h].avto in marki) = true then

begin

k := 0;

include(marki, x[h].avto);

for l:=h to n do

if x[h]=x[l] then

if x[l].avto in marki then

k:=k + 1;

writeln(x[h].avto, '-', k);

end;

end;

end;

Процедура ввода данных в запись.

procedure change(x: integer; var z: mas; var v: mas2);

begin

clrscr;

В контрольный массив ставим, что данная запись с этим номер заполнена.

v[x]:=true;

write('Vvedite familiu: ');

readln(z[x].familia);

write('Vvedite adress: ');

readln(z[x].adress);

write('Vvedite marku avto: ');

readln(z[x].avto);

write('Vvedite nomer avto: ');

readln(z[x].nomer);

z[x].Vypusk:= 0;

while (z[x].Vypusk < 1900) or (z[x].Vypusk > 2000) do

begin

write('Vvedite god vipuska(1900..2000): ');

readln(z[x].vypusk);

end;

end;

6                   Заключение.

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

7                   Приложения А

Код программы 1

program slova1;

uses crt;

type

 Stroka250=string[250];

 Slovo=string[20];

function Copy1(S: Stroka250; Start, Len: Integer):Stroka250;

 var

 Rez: Stroka250;

 L: Integer;

 I, J: Integer;

 begin

 L:=byte(S[0]);

 if (L<Start) then

 Rez[0]:=char(0)

 else

 begin

 if (Start+Len-1)>L then

 Len:=L-Start+1;

 J:=Start;

 for I:=1 to Len do

 begin

 Rez[I]:=S[J];

 Inc(J);

 end;

 Rez[0]:=char(Len);

 end;

 Copy1:=Rez;

 end;

 function isletter(C: Char): Boolean;

 begin

if ((C>='A') and (C<='Z')) or ((C>='a') and (C<='z')) then

 isletter:=True

 else

 isletter:=False;

 end;

function alforder(Sl: Slovo; var Count: Byte): Boolean;

 var

 I, L: Byte;

 F: Boolean;

 Buf: Char;

 begin

 L:=Length(Sl);

 Count:=0;

 for I:=1 to L do

 begin

 if (isletter(Sl[I])) then

 Inc(Count);

 if (Sl[I]>='A') and (Sl[I]<='Z') then

 Sl[I]:=char(byte(Sl[I])+32);

 end;

 {esli v slove net bukv}

 if Count=0 then

 alforder:=False

 else

 if Count=1 then

 alforder:=True

 else

 begin

 F:=True;

 While F do

 begin

 F:=False;

 for I:=1 to L-1 do

 if (Not isletter(Sl[I])) And (isletter(Sl[I+1])) then

 begin

 F:=True;

 Buf:=Sl[I];

 Sl[I]:=Sl[I+1];

 Sl[I+1]:=Buf;

 end;

 end;

 F:=true;

 for I:=1 to Count-1 do

 if Sl[I]>Sl[I+1] then

 begin

 F:=False;

 break;

 end;

 alforder:=F;

 end;
 end;

procedure alfslovo(S: Stroka250);

 var

 F: boolean;

 Len: Byte;

 I: Byte;

 Counter: Byte;

 FSlovo, Buf: Slovo;

 Index, L: Byte;

 MaxCol: Byte;

begin

 Len:=Length(S);

 if S[Len]<>' ' then

 begin

 S:=S+' ';

 Inc(Len);

 end;

 F:=False;

 MaxCol:=0;

 for I:=1 to Len do

 if S[I]<>' ' then

 begin

 if F=False then

 begin

 F:=True;

 Index:=I;

 L:=1;

 end

 else

 Inc(L);

 end

 else

 if F=True then

 begin

 F:=False;

 Buf:=Copy1(S, Index, L);

 Buf[0]:=char(L);

 if alforder(Buf, Counter) then

 begin

 if Counter>MaxCol then

 begin

 FSlovo:=Copy1(S, Index, L);

 FSlovo[0]:=char(L);

 MaxCol:=Counter;

 end;

 end;

 end;

 if MaxCol=0 then

 writeln('Net podhodyaschi slov v texte')

 else

 writeln(FSlovo, ' kol-vo bukv: ', MaxCol);

end;

function simmetr(S: Slovo):boolean;

var

 L, I, R: Byte;

 F: Boolean;

begin

 L:=Length(S);

 R:=L div 2;

 F:=True;

 for I:=1 to R do

 if S[I]<>S[L-I+1] then

 begin

 F:=False;

 break;

 end;

 simmetr:=F;

end;
procedure colsimmslovo(S: Stroka250);

 var

 F: boolean;

 Len: Byte;

 I: Byte;

 Counter: Byte;

 Buf: Slovo;

 Index, L: Byte;

 MaxCol: Byte;

begin

 Len:=Length(S);

 if S[Len]<>' ' then

 begin

 S:=S+' ';

 Inc(Len);

 end;

 F:=False;

 Counter:=0;

 writeln('Spisok simmetrichnyh slov iz bolshe chem 2 znaka:');

 for I:=1 to Len do

 if S[I]<>' ' then

 begin

 if F=False then

 begin

 F:=True;

 Index:=I;

 L:=1;

 end

 else

 Inc(L);

 end

 else

 if F=True then

 begin

 F:=False;

 if L>2 then

 begin

 Buf:=Copy(S, Index, L);

 Buf[0]:=char(L);

 if simmetr(Buf) then

 begin

 Inc(Counter);

 writeln(Buf);

 end;

 end;

 end;

 writeln('Kol-vo naidennyh slov: ', Counter);

end;
procedure menu;

begin

writeln;

writeln('++++++++++++++++++++++++++++++++++++++++++++++++');

writeln('+ Vvod texta --> 1 +');

writeln('+ Slovo s max. kol.bukv v alf. poryadke --> 2 +');

writeln('+ Simmetrichnye slova --> 3 +');

writeln('+ Vyvod texta --> 4 +');

writeln('+ +');

writeln('+ Konec --> 0 +');

writeln('++++++++++++++++++++++++++++++++++++++++++++++++');

writeln;

end;
var

 Txt: Stroka250;

 Vvod, Cont: Boolean;

 Rem: Char;

begin

Vvod:=False;

Cont:=True;

while Cont do

 begin

 clrscr;

 menu;

 write('Vvedite komandu: ');

 readln(Rem);

 case Rem of

 '0': Cont:=False;

 '1': begin

 writeln('Text:');

 readln(Txt);

 Vvod:=True;

 end;

 '2': begin

 if Not Vvod then

 writeln('Ne vveden text')

 else

 alfslovo(Txt);

 end;

 '3': begin

 if Not Vvod then

 writeln('Ne vveden text')

 else

 colsimmslovo(Txt);

 end;

 '4': begin

 if Not Vvod then

 writeln('Ne vveden text')

 else

 writeln(Txt);

 end

 else

 writeln('Neizvestnaya komanda');

 end;

 if Cont then

 begin

 write('Nagmite ENTER dlya vvoda sleduyuschei komandy... ');

 readln;

 end

 else

 clrscr;

end;
end.

8                   Приложение Б

Код программы 2

program massiv1;

uses crt;

type

 Matrix=array[1..20,1..20] of Integer;

type

 Vector=array[1..80] of Integer;

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

var

 Buf: Integer;

 I, J: Integer;

begin
 for J:=1 to Rev do

 begin

 Buf:=V[NN];

 for I:=NN downto 2 do

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

 V[1]:=Buf;

 end;

end;

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:=0;

 for K:=1 to R do

 begin

 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;

 Revers:=N-2*Ot-1;

 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;
end;

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

var

 I, J: Integer;

 D: Integer;

 R: Integer;

begin

 randomize;

 for I:=1 to N do

 for J:=1 to M do

 begin

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

 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;
var

 Matr: Matrix;

 N: Integer;

begin

 clrscr;

 repeat

 write('Razmer matricy (12..20): ');

 readln(N);

 until (N>=12) and (N<=20);

 FormMatrix(Matr, N, N);

 writeln('Sformirovana matrica:');

 PrintMatrix(Matr, N, N);

 TurnMatrix(Matr, N);

 writeln('Matrica posle povorota');

 PrintMatrix(Matr, N, N); readln;

end.

9                   Приложение В

Код программы 3

program textfile;
uses

 crt;
type

 arr = array [1..83] of string;
var

 slova1, slova2, slova: arr;

 m, m1, m2, k1, k2, k, l, g: integer;

 first, second, third: text;

 command: char;

 p, v, t, S1, S2: string;

 pf, vf, tf, cont, flag1, flag2: boolean;
function check2: boolean;

begin

 if eof(first) = true then flag1 := true else flag1 := false;

 if eof(second) = true then flag2 := true else flag2 := false;

 if (flag1 = false) and (flag2 = false) then check2 := false else check2 := true;

end;
procedure closing;

begin

 close(first);

 close(second);

 close(third);

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

var

 i, j, k: integer;

begin

 nc := 0;

 for i := 1 to na do

 begin

 k := 0;

 for j := 1 to nb do

 if a[i] = b[j] then k := 1;

 if k = 0 then

 begin

 nc := nc + 1;

 c[nc] := a[i];

 end;

 end;

 for i := 1 to nb do

 begin

 k := 0;

 for j := 1 to na do

 if b[i] = a[j] then k := 1;

 if k = 0 then

 begin

 nc := nc + 1;

 c[nc] := b[i];

 end;

 end;

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 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;

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

 close(first);

 reset(first);

 close(second);

 reset(second);

end;

procedure filepr;

begin

 assign(first, p);

 assign(second, v);

 assign(third, t);

 reset(first);

 reset(second);

 rewrite(third);

end;
function check1(x: string): boolean;

begin

 if length(x) > 0 then begin

 if x[1] <> ' ' then

 check1 := true;

 end;

end;
procedure menu;

begin

 writeln;

 writeln('++++++++++++++++++++++++++++++++++++++++++++++++');

 writeln('+ Vvod imeni pervogo faila --> 1 +');

 writeln('+ Vvod imeni vtorogo faila --> 2 +');

 writeln('+ Vvod imeni tretiego faila --> 3 +');

 writeln('+ Preobrazovat tretii fail --> 4 +');

 writeln('+ +');

 writeln('+ Konec --> 0 +');

 writeln('++++++++++++++++++++++++++++++++++++++++++++++++');

 writeln;

end;
begin

 menu;

 pf := false;

 vf := false;

 tf := false;

 cont := true;

 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);

 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);

 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);

 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.

1. Реферат на тему Горшечные растения
2. Лекция на тему Виды трудового договора Изменение трудового договора
3. Курсовая Обучение диалогической речи на основе развития речевых взаимодействий учащихся
4. Реферат на тему Modern Society Essay Research Paper During the
5. Реферат Принципы внедрения экологического менеджмента на предприятиях легкой промышленности
6. Реферат Фантастический реализм
7. Реферат на тему Nt Essay Research Paper IntroductionWhen mainframe and
8. Реферат Политические и социально-экономические права человека
9. Реферат Конкуренция на рынке платежных услуг в Интернете
10. Реферат Нижегородская ярмарка 2