Примеры Лабораторных работы на Delphi

[NATRIY]

Выкладываю лабораторный работы.
Может кому-нибудь они помогут, и будут началом для разработки своих программок.
В самой программе указано, задание.
Пользуйтесь на здоровице! Не забывайте о чел. благодарности!! ))))))))))))0

 

[Dock1100]

Задача №N
Создать однонаправленый(тут двунаправленый) список который вмещает информацию о имени реки и ее длине. Сделать процедуру для добавления, вставки и удаления елементов списка.

type TStringList=^TString;
TString = record
name_:string;
length_:integer;
prew : TStringList;
next : TStringList;
end;

var list,top,bottom:TStringList;
i:integer;
name_:String;
length_:integer;

procedure add(var list,top,bottom:TStringList; name_:string; legnth_:integer);
begin
new(list);
list^.name_:=name_;
list^.length_:=length_;
list^.prew:=top;
if top=nil then bottom:=list;
if list^.prew<>nil then List^.prew^.next:=list;
list^.next:=nil;

top:=list;
end;

procedure insert(var list,top,bottom:TStringList; after:integer; name_:string; length_:integer);
var k,k2:TStringList;
begin
k2:=bottom;
if after <>0 then
for i:=1 to after do
k2:=k2^.next;
new(k);
k^.name_:=name_;
k^.length_:=length_;
k^.prew:=k2;
k^.next:=k2^.next^.next;
k2^.next:=k;
end;

procedure Write(list,bottom:TStringList; from_first:boolean);
begin
if not from_first then
while list<>nil do
begin
writeln('name : ',list^.name_);
writeln('length : ',list^.length_);
writeln;
list:=list^.prew;
end
else
while bottom<>nil do
begin
writeln('name : ',bottom^.name_);
writeln('length : ',bottom^.length_);
writeln;
bottom:=bottom^.next;
end
end;


procedure remove(var list,top,bottom:TStringList; after:integer);
var k,k2:TStringList;
begin
k2:=bottom;
if after <>0 then
for i:=1 to after-1 do
k2:=k2^.next;

k2^.next:=k2^.next^.next;

end;


begin
top:=nil;
bottom:=nil;
for i:=1 to 5 do
begin
writeln('enter river''s name');
readln(name_);
writeln('enter river''s length');
readln(length_);
add(list,top,bottom,name_,length_);
end;
write(list,bottom,true);
readln;
insert(list,top,bottom,2,'new river',102);//вставка после второго елемента
write(list,bottom,true);
readln;
remove(list,top,bottom,1);// уничтожение второго елемента
write(list,bottom,true);
readln;
end.

 

[Dock1100]

Тема: Умножение матриц
Марица*матрицу
матрица*столбик

uses crt;
const m=3;
n=5;
k=7;
type mas1=array[1..m,1..n] of integer;
type mas2=array[1..n,1..k] of integer;
type mas3=array[1..m,1..k] of integer;
type mas4=array[1..n] of integer;
type mas5=array[1..m] of integer;

var a:mas1;
b:mas2;
c:mas3;
x:mas4;
s:mas5;
action,action2:integer;

procedure matrix_write(a_:mas1;b_:mas2;c_:mas3;x:integer);
var i,j:integer;
begin
case x of
1:
for i:=1 to m do
begin
write('| ');
for j:=1 to n do
write(a_[i,j]:4,' | ');
writeln;
end;
2:
for i:=1 to n do
begin
write('| ');
for j:=1 to k do
write(b_[i,j]:4,' | ');
writeln;
end;
3:
for i:=1 to m do
begin
write('| ');
for j:=1 to k do
write(c_[i,j]:4,' | ');
writeln;
end;
end;
end;

procedure matrix_read(var a_:mas1;var b_:mas2;x_:integer);
var i,j:integer;
begin
case x_ of
1:
for i:=1 to m do
for j:=1 to n do
begin
write(' a[',i,',',j,'] = ');
readln(a_[i,j]);
end;
2:
for i:=1 to n do
for j:=1 to k do
begin
write(' b[',i,',',j,'] = ');
readln(b_[i,j]);
end;
end;
end;

procedure colum_write(x_:mas4; s_:mas5;n:integer);
var i:integer;
begin
case n of
1:
begin
write('| ');
for i:=1 to n do
write(x_[i]:4,' | ');
writeln;
end;
2:
begin
write('| ');
for i:=1 to m do
write(s_[i]:4,' | ');
writeln;
end;
end;
end;

procedure colum_read(var x_:mas4);
var i:integer;
begin
for i:=1 to n do
begin
write(' x[',i,'] = ');
readln(x[i]);
end;
end;

procedure matrix_on_colum(a_:mas1;x_:mas4;var s_:mas5);
var i,j:integer;
begin
for i:=1 to m do
s_[i]:=0;

for i:=1 to m do
for j:=1 to n do
s_[i]:=s_[i]+a_[i,j]*x_[j];
end;


procedure matrix_on_matrix(a_:mas1;b_:mas2;var c_:mas3);
var i,j,p:integer;
begin
for i:=1 to m do
for j:=1 to k do
c_[i,j]:=0;
for i:=1 to m do
for j:=1 to k do
for p:=1 to n do
c_[i,j]:=c_[i,j]+a_[i,p]*b_[p,j];
end;


begin
while action<>4 do
begin
clrscr;
writeln('1. Enter arrays');
writeln('2. Show arrays');
writeln('3. Multiply arrays');
writeln('4. Exit');
readln(action);
case action of
1:
begin
clrscr;
writeln('1. Enter matrix ''a''');
writeln('2. Enter matrix ''b''');
writeln('3. Enter colum ''x''');
readln(action2);
case action2 of
1: matrix_read(a,b,1);
2: matrix_read(a,b,2);
3: colum_read(x);
end;
end;

2:
begin
clrscr;
writeln('1. Show matrix ''a''');
writeln('2. Show matrix ''b''');
writeln('3. Show matrix ''c''');
writeln('4. Show colum ''x''');
writeln('5. Show colum ''s''');
readln(action2);
case action2 of
1: matrix_write(a,b,c,1);
2: matrix_write(a,b,c,2);
3: matrix_write(a,b,c,3);
4: colum_write(x,s,1);
5: colum_write(x,s,2);
end;
end;
3:
begin
clrscr;
writeln('1. c=a*b');
writeln('2. s=a*x');
readln(action2);
case action2 of
1:
begin
matrix_on_matrix(a,b,c);
matrix_write(a,b,c,3);
end;
2:
begin
matrix_on_colum(a,x,s);
colum_write(x,s,2);
end;
end;
end;


end;
readln;
end;
end.

 

[Dock1100]

Тесты, работают с тхт файлами, тхт файл может содержать в себе несколько тестов (каждый из которых имеет по неколько вопросов).