Автор: sandman 26.03.2004 3:23
Нашел тут в своей файлопомойке несколько лаб... может быть кому нужны...
На лаконичность кода ЭТО не претендует... Если чего еще найду - закину
1:
Код
{Из элементов массива A(2n) получить массивы B(n) и C(n) следующим образом.
Выбрать в массиве A два наиболее близких по значению элемента;
меньший из них поместить в массив B, а больший в массив C.
Продолжить выбор из оставшихся элементов до полного заполнения массивом B и C.}
{$R-}
program Neighbours;
type arr1=array[1..1] of integer;
arr1Pointer=^arr1;
var dynArray, small1, small2: arr1Pointer;
counter, k, m: integer;
{ counter - вводимое количество элементов массива
k - число элементов малого массива
m - номер элемента, удаляемого процедурой delElem }
procedure CreateMainArr(var counter:integer); {создание основного динамического массива и заполнение его числами}
var i, j: integer;
begin
repeat
write('Введите чётное число элементов массива: '); {размер массива}
readln(counter);
until (counter mod 2)=0; {число элементов массива должно быть четным}
getMem(dynArray,counter*sizeOf(integer));
writeln('Значение любого элемента не должно превышать 32766!');
for i:=1 to counter do
begin
write('Введите ',i,' элемент: ');
readln(j);
if j>=maxint then
begin
writeln('!недопустимое число! попробуйте еще раз...');
write('Введите ',i,' элемент: ');
readln(j);
end
else
dynArray^[i]:=j; {заполнение массива значениями}
end;
end;
{выделение памяти под два малых массива, с кол-вом элементов в 2 раза меньше, чем в основном}
procedure CreateTwoSmallArrays(const counter:integer);
begin
k:=counter div 2;
writeln('Создание массивов...');
getMem(small1,k*sizeOf(integer));
getMem(small2,k*sizeOf(integer));
end;
{распределение чисел между массивами}
procedure MoreOrLess(const counter:integer);
var l, p, i, j, x: integer;
begin {сортировка пузырьком}
p:=1;
for i:=1 to counter-1 do
begin
for j:=i+1 to counter do
begin
if dynArray^[i]>dynArray^[j] then
begin
x:=dynArray^[i]; dynArray^[i]:=dynArray^[j]; dynArray^[j]:=x;
end;
end;
end;
{распределение элементов по малым массивам (парами)}
i:=0;
repeat
small1^[p]:=dynArray^[i+1];
small2^[p]:=dynArray^[i+2];
inc(p); i:=i+2;
until i=counter;
end;
begin
CreateMainArr(counter);
CreateTwoSmallArrays(counter);
MoreOrLess(counter);
writeln('Первый массив:'); {массив B}
for m:=1 to k do
begin
write(small1^[m],' ');
end;
writeln;
writeln('Второй массив:');
for m:=1 to k do {массив C}
begin
write(small2^[m],' ');
end;
writeln;
k:= counter div 2;
writeln('Очистка памяти...');
freeMem(dynArray,counter*sizeOf(integer));
freeMem(small1,k*sizeOf(integer));
freeMem(small2,k*sizeOf(integer));
readln;
writeln('ok')
end.
2 поинтересней
Код
{Заданное число (не обязательно целое) отложить на бухгалтерских счётах,
изображённых на экране.}
program Counters;
uses crt, graph;
var s, d, e, sd, dd, ed, code: integer;
{ s - количество сотен во введенном числе
d - количество десятков
e - кол-во единиц
sd - кол-во тысячных долей
dd - кол-во сотых долей
ed - кол-во десятых }
{обработка введенного пользователем числа}
procedure InputAndProcess;
var a:real;
n:string;
i:integer;
begin
repeat
writeln('ВНИМАНИЕ! будут обработаны только первые 3 знака после запятой!');
write('введите число < 1000 (необязательно целое): ');
readln(a);
clrscr;
until a<1000;
str(a:5:3,n);
for i:=2 to length(n) do {разделение целой и дробной частей}
begin
if n[i]='.' then
begin
if i=4 then
begin
val(n[1],s,code);
val(n[2],d,code);
val(n[3],e,code);
end;
if i=3 then
begin
s:=0;
val(n[1],d,code);
val(n[2],e,code);
end;
if i=2 then
begin
s:=0;
d:=0;
val(n[1],e,code);
end;
val(n[i+1],ed,code);
val(n[i+2],dd,code);
val(n[i+3],sd,code);
break;
end;
end;
end;
{создание основы счет (без делений)}
procedure Bones;
var driver, mode, codeError:integer;
i, j, x0, y0:integer;
begin
Driver:=Detect;
InitGraph(driver,mode,'');
if GraphResult <>0 then writeln(GraphErrorMsg(Codeerror));
x0:=GetMaxX; y0:=GetMaxY;
SetBkColor(black);
SetColor(brown);
SetLineStyle(0,3,3);
line(round(x0)div 3, (round(y0) div 5) , (round(x0) div 3)*2, round(y0)div 5);
line((round(x0)div 3)*2, round(y0) div 5, (round(x0) div 3)*2,(round(y0)div 5)*4);
line((round(x0)div 3)*2,(round(y0) div 5)*4, round(x0)div 3, (round(y0)div 5)*4);
line(round(x0)div 3, (round(y0) div 5)*4, round(x0) div 3, round(y0) div 5);
j:=(round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4;
SetLineStyle(0,3,1);
for i:=1 to 6 do
begin
moveto(round(x0)div 3,j);
lineto((round(x0)div 3)*2,j);
j:=j+(((round(y0)div 5)*4) div 9);
end;
end;
{добавление какого-либо количества делений справа}
procedure AddToRight;
var x, y, xtemp, x0, y0, i: integer;
begin
SetFillStyle(1,brown);
x0:=GetMaxX; y0:=GetMaxY;
{сотни}
if s<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4);
for i:=1 to s do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
{десятки}
if d<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*2)-4);
for i:=1 to d do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
{единицы}
if e<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*3)-4);
for i:=1 to e do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
{десятые доли}
if ed<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*4)-4);
for i:=1 to ed do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
{сотые доли}
if dd<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*5)-4);
for i:=1 to dd do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
{тысячные доли}
if sd<>0 then
x:=(((round(x0)div 3)*2)-7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*6)-4);
for i:=1 to sd do
begin
pieslice(x,y,0,360,6);
x:=x-14;
end;
end;
{добавление какого-либо количества делений слева}
procedure AddToLeft;
var s1, d1, e1, sd1, dd1, ed1, x, y, x0, y0, i: integer;
begin
s1:=9-s; d1:=9-d; e1:=9-e; sd1:=9-sd; dd1:=9-dd; ed1:=9-ed;
SetFillStyle(1,brown);
x0:=GetMaxX; y0:=GetMaxY;
{сотни}
if s1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4);
for i:=1 to s1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
{десятки}
if d1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*2)-4);
for i:=1 to d1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
{единицы}
if e1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*3)-4);
for i:=1 to e1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
{десятые доли}
if ed1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*4)-4);
for i:=1 to ed1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
{сотые доли}
if dd1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*5)-4);
for i:=1 to dd1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
{тысячные доли}
if sd1<>0 then
x:=((round(x0)div 3)+7);
y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*6)-4);
for i:=1 to sd1 do
begin
pieslice(x,y,0,360,6);
x:=x+14;
end;
end;
begin
InputAndProcess;
Bones;
AddToRight;
AddToLeft;
readln;
closegraph;
writeln('.');
readln;
end.
Автор: sandman 26.03.2004 3:24
О... еще нашел... только в одной из версий этой лабы бага была.. непомню тут она пофикшена или нет ;)
Код
{условие (дословно):
распределение скорости ветра по каждому из восьми направлений
задано массивом из 8 чисел. Построить "розу ветров" с указанием
направлений}
program PO3A_BETPOB;
uses crt, graph;
type Napr_N=1..8;
Koord=1..2;
var
Napr:Napr_N;
Napr_text:string[16];
data:array[Napr_N] of word;
Karta:array[Napr_N,Koord] of real;{Koord=1 - ось X, Koord=2 - ось Y}
Xmin,Xmax,Ymin,Ymax:real;
Simvol:char;
{процедура ввода чисел в массив}
Procedure input;
var i: integer;
begin
TextColor(yellow);
TextBackGround(blue);
clrscr;
for Napr:=1 to 8 do {Ввод чисел, каждое - сила ветра}
{по одному из восьми направлений}
begin
case Napr of {Выбор одного направления ветра}
1:Napr_text:='восточного';
2:Napr_text:='северо-восточного';
3:Napr_text:='северного';
4:Napr_text:='северо-западного';
5:Napr_text:='западного';
6:Napr_text:='юго-западного';
7:Napr_text:='южного';
8:Napr_text:='юго-восточного'
end;
{Ввод и проверка числа дней с выбранным направлением ветра}
repeat
TextColor(white);
write('Сила ',Napr_text,' ветра: ');
TextColor(lightred);
readln(data[Napr]);
clrscr;
until data[Napr]>=0;
end;
end;
{просчет пропорций области карты}
procedure Oblast;
var
Koeff:real;
begin
Koeff:=Sqrt(2)/2; {Коэффициент для промежуточных направлений ветра}
for Napr:=1 to 8 do
begin
case Napr of
1:begin Karta[Napr,1]:=data[Napr];
Karta[Napr,2]:=0 end;
2:begin Karta[Napr,1]:=data[Napr]*Koeff;
Karta[Napr,2]:=Karta[Napr,1] end;
3:begin Karta[Napr,1]:=0;
Karta[Napr,2]:=data[Napr] end;
4:begin Karta[Napr,1]:=-data[Napr]*Koeff;
Karta[Napr,2]:=-Karta[Napr,1] end;
5:begin Karta[Napr,1]:=-data[Napr];
Karta[Napr,2]:=0 end;
6:begin Karta[Napr,1]:=-data[Napr]*Koeff;
Karta[Napr,2]:=Karta[Napr,1] end;
7:begin Karta[Napr,1]:=0;
Karta[Napr,2]:=-data[Napr] end;
8:begin Karta[Napr,1]:=data[Napr]*Koeff;
Karta[Napr,2]:=-Karta[Napr,1] end
end;
end;
Xmin:=Karta[1,1]; Xmax:=Karta[1,1];
Ymin:=Karta[1,2]; Ymax:=Karta[1,2];
for Napr:=2 to 8 do
begin
if Karta[Napr,1]<Xmin then Xmin:=Karta[Napr,1];
if Karta[Napr,1]>Xmax then Xmax:=Karta[Napr,1];
if Karta[Napr,2]<Ymin then Ymin:=Karta[Napr,2];
if Karta[Napr,2]>Ymax then Ymax:=Karta[Napr,2];
end;
if (Xmin=Xmax) or (Ymin=Ymax) then
begin
writeln('С этими данными график не построить -');
writeln('Xmin=',Xmin:0:2,' Xmax=',Xmax:0:2,' Ymin=',Ymin:0:2,' Ymax=',Ymax:0:2);
writeln('Попробуйте использовать другие значения');
halt;
end;
writeln; TextColor(yellow);
writeln('Область графика: ',Xmin:0:2,'<=X<=',Xmax:0:2,';', Ymin:0:2,'<=Y<=',Ymax:0:2);
writeln; TextColor(white);
writeln('Здесь учтен коэффициент, равный SQRT(2)/2 для направлений:');
writeln('северо-восток, северо-запад, юго-запад, юго-восток');
writeln;
write('Если Вас устраивает область графика, нажмите клавишу 1 и <Enter> ');
readln(Simvol);
if Simvol<>'1' then
begin
writeln('Готовьте новые значения переменных и',
' запускайте программу. Желаем успехов.');
readln;
halt
end;
end;
{построение графика}
procedure Grafik;
var
Driver,Mode,Code_error:integer;
X0,Y0:integer;
Coords:array[Napr_N,Koord] of word;
Mx,My,M:real;
begin
Driver:=Detect; {Автоопределяющийся тип драйвера}
InitGraph(driver,mode,''); {Файл Graph.tpu - в текущем каталоге ('')}
if GraphResult <>0 then writeln(GraphErrorMsg(Code_error));
{Определение масштабного множителя М=min(Mx,My)}
Mx:=(GetMaxX-30)/(Xmax-Xmin); {15 - отступ по оси X от края окна}
My:=(GetMaxY-20)/(Ymax-Ymin); {10 - отступ по оси Y от края окна}
if Mx<My then M:=Mx else M:=My;
SetBkColor(black);
{Определение местонахождения точки (Х0,У0) - начала координат}
X0:=round(-Xmin*M+(GetMaxX-(Xmax-Xmin)*M)/2);
Y0:=round(Ymax*M+(GetMaxY-(Ymax-Ymin)*M)/2);
SetLineStyle(0,3,2);
SetColor(green);
Coords[1,1]:=X0+round(Karta[1,1]*M);
Coords[1,2]:=Y0-round(Karta[1,2]*M);
MoveTo(Coords[1,1],Coords[1,2]);
for Napr:= 2 to 8 do
begin
Coords[Napr,1]:=X0+round(Karta[Napr,1]*M);
Coords[Napr,2]:=Y0-round(Karta[Napr,2]*M);
{Проводим отрезок прямой от текущего указателя до точки Napr}
LineTo(Coords[Napr,1],Coords[Napr,2])
end;
LineTo(Coords[1,1],Coords[1,2]); {Замыкаем ломаную}
SetFillStyle(11,lightred);
FloodFill(X0,Y0,green);
SetColor(white);
SetLineStyle(0,0,1);
Line(0,Y0,GetMaxX-10,Y0); OutTextXY(GetMaxX-15,Y0-3,'>');
Line(X0,4,X0,GetMaxY); OutTextXY(X0-3,1,'^');
SetTextStyle(2,0,0);
OutTextXY(GetMaxX-25,Y0+6,'X');
OutTextXY(X0-12,1,'Y');
OutTextXY(X0-12,Y0+6,'0');
SetColor(yellow);
SetLineStyle(3,0,1);
Napr:=2;
repeat
Line(X0,Y0,Coords[Napr,1],Coords[Napr,2]);
Napr:=Napr+2;
until Napr>8;
{Надписи сторон света}
SetTextStyle(3,HorizDir,1);
OutTextXY(10,Y0-10,'West');
OutTextXY(GetMaxX-40,Y0-10,'East');
SetTextStyle(3,VertDir,1);
OutTextXY(X0-5,10,'North');
OutTextXY(X0-5,GetMaxY-40,'South');
SetViewPort(10,5,130,55,ClipOn);
SetColor(green);
SetTextStyle(DefaultFont,HorizDir,1);
SetTextJustify(CenterText,CenterText);
{OutTextXY(60,15,'Р О З А');
OutTextXY(60,30,'В Е Т Р О В'); }
readln;
end;
{main}
begin
repeat
input; {Ввод исходных данных}
Oblast; {Нахождение границ области графика, преобр.координат}
Grafik; {Построение графика}
readln;
RestoreCrtMode; {Временный выход в текстовый режим работы монитора}
readln;
TextBackGround(blue);
TextColor(yellow);
ClrScr; GoToXY(15,10);
write('Повторить c начала? Да - введите 1 и нажмите <Enter> ');
readln(Simvol)
until Simvol <> '1';
CloseGraph;
TextMode(Co40);
TextBackGround(white); TextColor(magenta);
Window(2,5,39,19);
ClrScr; GoToXY(4,7);
writeln('...press a key to exit...');
ReadKey;
end.