Работа с текстовыми строками, двумерными массивами, файловыми структурами данных
Вначале программа проверяет, введено ли общее число элементов. Затем проверяет каждый элемент по очереди. Если все они заполнены, то начинается выполнятся процедура по подсчету машин каждой марки. Делаем несколько циклов, среди которых перебираем элементы первого массива и сравниваем их со вторым. Затем элементы вторго с элементами первого и оставшиеся заносятся в новый массив. Если текст… Читать ещё >
Работа с текстовыми строками, двумерными массивами, файловыми структурами данных (реферат, курсовая, диплом, контрольная)
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.