Работа с текстовыми строками, двумерными массивами, файловыми структурами данных

1 Задание № 1.

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

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

2 Задание № 2.

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

2.2 Работа программы.

3 Задание № 3.

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

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

4 Задание № 4.

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

5 Задание № 5.

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

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

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

7 Список используемой литературы.

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

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

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

11 Приложение Г

12 Приложение Д

1 Задание № 1

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

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

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

Основное тело программы.

Begin

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

Vvod:=False;

Cont:=True;

while Cont do

Begin

Очмщаем экран для удобства ввода и вывода информации.

clrscr;

Выводим меню с номерами команд, которое можно увидеть на рисунке 1.

Рисунок 1 — главное меню первой программы.

menu;

write ('Vvedite komandu: ');

Считываем команду в переменную Rem.

readln (Rem);

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

case Rem of

'0': Cont:=False;

'1': begin

Считываем введенную строку в переменную Txt и присваиваем Vvod значение True, показывая, что текст введен.

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

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

writeln ('Neizvestnaya komanda');

end;

Если программа все еще работает, то выводится предупреждающее сообщение о том что после нажатия клавиши ENTER необходимо будет ввести следующую команду.

if Cont then

begin

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

readln;

end

else

clrscr;

end;

end.

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

Она получает в качестве параметра строку S и считает в ней слова, в которых латинские буквы расположены по алфавиту и печатает такое слово, в котором максимально количество букв.

procedure alfslovo (S: Stroka250);

var

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

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

Если находим начало нового слова, тогда устанавливаем признак нового слова, запоминаем номер символа начала слова в строке в переменную Index и вводим начальную длину слова в L.

if F=False then

begin

F:=True;

Index:=I;

L:=1;

end

else

Увеличиваем длину до тех пор, пока не находим пробел.

Inc (L);

end

else

Если i-й символ пробел, то сбрасываем признак слова, копируем слово в переменную Buf и длину строки в нулевую ячейку.

if F=True then

begin

F:=False;

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

Buf[0]: =char (L);

Следующая процедура проверяет слово. Если буквы расположены в алфавитном порядке, то возвращает True иначе False.

if alforder (Buf, Counter) then

begin

Если в слове больше символов, чем в максимальном, то заносим слово в Fslovo и колличество букв в MaxCol.

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;

Функция alforder получает в качестве параметров строку S1, если в строке латинские буквы расположены по алфавиту, то функция вернет True иначе False. Count — количество латинских букв в строке.

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;

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

Если i-й символ не буква, а его сосед справа — буква, то меняем эти символы местами.

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;

Процедура colsimmsolvo получает в качестве параметра строку S, и считает в ней симметричные слова, выводит их на экран и выводит количество найденных симметричных слов.

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 обозначаем флаг нахождения слова, F=trueнайдено новое слово. И сбрасываем начальное значение количества симметричных слов.

F:=False;

Counter:=0;

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

Начинаем поиск симметричных слов в строке.

for I:=1 to Len do

В случае, если i-й символ не пробел, устанавливаем флаг нового слова, запоминаем начало нового слова, и сбрасываем начальное значение длинны.

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); {kopiruem slovo v Buf}

Buf[0]: =char (L);

Далее функцией проверяем слово на симметрию, и если оно симметрично, то увеличиваем счетчик на единицу, и выводим это слово на экран.

if simmetr (Buf) then

begin

Inc (Counter);

writeln (Buf);

end;

end;

end;

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

end;

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

function simmetr (S: Slovo):boolean;

var

L, I, R: Byte;

F: Boolean;

Begin

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

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;

2 Задание № 2

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

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

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

Вначале задаем 2 типа: самой матрицы и буффера.

type

Matrix=array[1.20,1.20] of Integer;

type

Vector=array[1.80] of Integer;

Begin

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

clrscr;

Повторяем ввод до тех пор, пока не будет введено число от 12 до 22.

repeat

write ('Razmer matricy (12.20): ');

readln (N);

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

Используем процедуру для формирования матрицы Matr размером N на N ячеек. Затем выводим ее на экран.

FormMatrix (Matr, N, N);

writeln ('Sformirovana matrica:');

PrintMatrix (Matr, N, N);

Используем процедуру поворота матрицы и выводим матрицу на экран.

TurnMatrix (Matr, N);

writeln ('Matrica posle povorota');

PrintMatrix (Matr, N, N);

readln;

end.

Процедура FormMatrix

Данная процедура присваивает значения от -99 до 99 элементам матрицы.

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

Присваиваем элементу любое значение от 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;

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

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

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

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

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

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

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.

10 Приложение Г

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

program grafik;

uses

graphabc;

var

xx, yy, a, d, maxy, maxx: integer;

t, k: real;

fileg: text;

cont, namef: boolean;

command: char;

name: string;

function Yfunc (i: real): real;

begin

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

end;

function Xfunc (i: real): real;

begin

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

end;

procedure mnoj;

begin

t := 0;

while t <= 2 * pi do

begin

xx := trunc (Xfunc (t));

if abs (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;

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

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;

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

begin

writeln;

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

writeln ('+ Vvod imeni faila s parametrami —> 1 +');

writeln ('+ Porstroenie grafika —> 2 +');

writeln ('+ Vihod —> 0 +');

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

writeln;

end;

procedure resize;

begin

mnoj;

ClearWindow;

graf;

redraw;

lockdrawing;

end;

begin;

t := 0;

menu;

cont := true;

while cont do

begin

Writeln ('Vvedite komady: ');

Readln (command);

case command of

'0': cont := false;

'1':

begin

writeln;

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;

lockdrawing;

OnResize := resize;

end.

11 Приложение Д

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

program zapisi;

uses

crt;

type

vladelez = record

Familia: string;

Adress: string;

Avto: string;

Nomer: string;

Vypusk: integer;

end;

mas2 = array [1.200] of boolean;

mas = array [1.200] of vladelez;

var

command: char;

cont, fzap, dzap: boolean;

avtovl: mas;

n: integer;

i: integer;

ch: mas2;

marki: set of string;

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

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

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;

procedure menu;

begin

writeln;

Writeln ('+++++++++++++++++++++++++++++++++++++++++++++++++++++');

writeln ('+ Ykazat kolichestvo zapisei ->1 +');

writeln ('+ Izmenit vse zapisi ->2 +');

writeln ('+ Izmenit odny zapis ->3 +');

writeln ('+ Kolichestvo avtomobilei kazdoi marki ->4 +');

writeln ('+ Vladelec samogo starogo avtomobila ->5 +');

writeln ('+ Familii vladelcev i nomera avto dannoi marki ->6 +');

Writeln ('+ +');

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

Writeln ('+++++++++++++++++++++++++++++++++++++++++++++++++++++');

writeln;

end;

begin

for i := 1 to 200 do

ch[i] := false;

clrscr;

menu;

cont := true;

fzap := false;

while cont do

begin

write ('Vvedite komandu: ');

readln (command);

case command of

'0': cont := false;

'1':

begin

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

change (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.