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
2. Статья на тему Индия Беспредельная мудрость
3. Кодекс и Законы Исторические и теоретические предпосылки возникновения социологии права
4. Диплом Злоупотребление должностными полномочиями 2
5. Реферат Анализ рынка сотовой связи Санкт-Петербурга
6. Сочинение на тему Лермонтов м. ю. - Стихотворение м. ю. лермонтова родина.
7. Реферат на тему История высшего образования в Украине
8. Реферат на тему П А Столыпин Другие реформы
9. Реферат Электропривод и автоматизация главного привода
10. Диплом на тему Модернизация сайта ПРИПИТ с использованием системы управления содержимым сайта CMS