Работа с текстовыми строками, двумерными массивами, файловыми структурами данных (стр. 3 из 5)
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);