docck
Advanced Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Код:
uses crt;
type pitem=^item;
item=record
data:integer;
next:pitem;
end;
var A,B,C,headA,headB,headC:pitem;
i,n1,n2,buf:integer;
vybor:char;
{Вычисление числа элементов списка}
function Kol(head:pitem):integer;
var p:pitem;
k:integer;
fl:boolean;
begin
k:=0;
fl:=false;
if head<>nil then {esli spisok ne pustoi}
begin
p:=head;
while p<>nil do {prohodim ot nachala i do konca}
begin
inc(k); {i uvelichibaem schetchik}
p:=p^.next;
if p=head then
if fl then break {esli spisok kolcevoi zavershaem cikl}
else fl:=true;
end;
end;
Kol:=k
end;
{Добавление элемента в список: info - chto nuzhno dobavit; poz - na kakuiu poziciu; head - nachalo spiska, v kotoryi vstavliaem}
procedure Add(info,poz:integer; var head:pitem);
var p,work:pitem;
k:integer;
begin
if (poz<=0) or (poz>Kol(head)+1) then
begin
writeln('Element NE mozhet byt vstavlen na etu poziciu!');
readkey;
exit;
end;
{esli pozicia korrektna}
new(work);
work^.data:=info;
if poz=1 then {esli pervaia}
begin
work^.next:=head;
head:=work; {zapominaem dobavlennyi element nachalom}
end
else {esli ne pervaia}
begin
p:=head;
for k:=2 to poz-1 do p:=p^.next; {doshli do nuzhnoi pozicii}
work^.next:=p^.next;
p^.next:=work; {vstavili ssylku na element}
end;
end;
{ Удаление n-го элемента из списка }
procedure Delete(poz:integer; var head:pitem);
var work,p:pitem;
k:integer;
begin
if (poz<=0) or (poz>Kol(head)) then
begin
writeln('Na etoi pozicii NET elementa!');
readkey;
exit;
end;
{esli pozicia korrektna}
if poz=1 then {esli pervaia}
begin
work:=head^.next;
dispose(head); {udalili nachalo}
head:=work; {zapomnili nachalom sleduiuschii}
end
else
begin
work:=head;
for k:=2 to poz-1 do work:=work^.next; {doshli do pozicii}
p:=work^.next;
work^.next:=p^.next; {iskluchili ssylku}
dispose(p); {osvobodili pamiat}
end;
end;
{ Создание копии списка }
function Copy(head:pitem):pitem;
var p0,p:pitem;
begin
p0:=head;
while p0<>nil do {prohodim ot nachalo do konca}
begin
p:=p0; {i kopiruem elementy}
p0:=p0^.next;
end;
Copy:=p;
end;
{ Сцепление двух списков }
function Concat(head1,head2:pitem):pitem;
var p:pitem;
ch:char;
begin
ch:='_';
if head1=head2 then
begin
write('Sceplenie privedet k sozdaniu kolcevogo spiska! Prodolzhit? [y/n] ');
ch:=upcase(readkey);
writeln;
end;
if (head1<>head2) or (ch<>'N') then
begin
p:=head1;
while p^.next<>nil do p:=p^.next; {dohodim do konca pervogo spiska}
p^.next:=head2; {i delaem ssylku, chtoby etot element
ukazyval na nachalo vtorogo}
Concat:=p;
writeln('Sceplenie spiskov proizvedenno.');
end
else
begin
Concat:=nil;
writeln('Sceplenie spiskov NE proizvedenno!');
end;
end;
{ Инвертирование списка, при котором первый элемент становится последним }
procedure Invert(var head:pitem);
var p,p1,p2,head2:pitem;
k,j,m:integer;
begin
k:=Kol(head);
p:=head;
j:=0;
head2:=nil;
while p<>nil do {prohodim ot nachala do konca}
begin
p1:=head;
for m:=1 to k-1 do p1:=p1^.next; {berem element s konca}
inc(j);
Add(p1^.data,j,head2); {i vstavliem ego v nachalo novogo spiska }
p:=p^.next;
if k>1 then dec(k); {elemnty posle k obrabotanny}
end;
head:=head2;
writeln('Invertirovanie proizvedenno.');
end;
{Создание списка, представляющего собой объединение (по операции ИЛИ) элементов двух списков}
function A_OR_B(head1,head2:pitem):pitem;
var p1,p2:pitem;
fl:boolean;
begin
p1:=head2;
{posledovatelno sravnivaem elementy pervogo spiska
s elementami vtorogo}
while p1<>nil do
begin
p2:=head1;
fl:=true;
while p2<>nil do
begin
if p1^.data=p2^.data then
begin
fl:=false;
break;
end
else p2:=p2^.next;
end;
if fl=true then {esli vo vtorom spiske est element, kotorogo net v pervom spiske}
begin
Add(p1^.data,Kol(head1)+1,head1); {dobavliem ego v pervyi spisok}
end;
p1:=p1^.next;
end;
A_OR_B:=head1;
writeln('Obiedenenie proizvedeno.');
end;
{Размещение элементов списка в возрастающем порядке}
function Sort(head:pitem):pitem;
var newh,max,prev,pmax,cur:pitem;
begin
newh:=nil;
while head<>nil do
begin
max:=head;
prev:=head;
cur:=head^.next;
while cur<>nil do
begin
if cur^.data>max^.data then
begin
max:=cur;
pmax:=prev;
end;
prev:=cur;
cur:=cur^.next;
end;
if max=head then head:=head^.next
else pmax^.next:=max^.next;
max^.next:=newh; newh:=max;
end;
Sort:=newh;
writeln('Sortirovka proizvedenna.');
end;
{pechat elementov spiska}
procedure WriteList(head:pitem);
var p:pitem;
k:integer;
begin
p:=head;
k:=0;
while (p<>nil) and (k<kol(head)) do
begin
write(p^.data,' ');
p:=p^.next;
inc(k);
if keypressed then break;
end;
end;
{OSNOVNAIA PROGRAMMA}
begin
{do nachala vseh operacii vse spiski pustye}
HeadA:=nil;
HeadB:=nil;
HeadC:=nil;
clrscr;
write('Zadaite kol-vo elementov pervogo spiska: ');
readln(n1);
writeln('Vvodite elementy: ');
for i:=1 to n1 do
begin
write('-> ');
readln(buf);
Add(buf,i,HeadA);{zapolnili pervyi spisok}
end;
write('Spisok: ');
WriteList(HeadA); {vyveli ego}
writeln;
writeln;
write('Hotite dobavit element na proizvolnuiu poziciu? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
write('Vvedite element: ');
readln(buf);
write('Vvedite poziciu: ');
readln(n1);
Add(buf,n1,HeadA); {dobavliem element}
write('Spisok: ');
WriteList(HeadA); {vyvodim izemennenyi spisok}
writeln;
writeln('Kol-vo elementov: ',Kol(HeadA)); {vyvodim kol-vo elementov spiska}
end;
writeln;
write('Hotite udalit element na proizvolnoi poziciu? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
write('Vvedite poziciu: ');
readln(n1);
Delete(n1,HeadA); {udaliaem element}
write('Spisok: ');
WriteList(HeadA); {vyvodim izemennenyi spisok}
writeln;
writeln('Kol-vo elementov: ',Kol(HeadA)); {vyvodim kol-vo elementov spiska}
readln;
end;
{analogichno s pervym zapolniem vtoroi spisok}
clrscr;
write('Zadaite kol-vo elementov vtorogo spiska: ');
readln(n2);
writeln('Vvodite elementy: ');
for i:=1 to n2 do
begin
write('-> ');
readln(buf);
Add(buf,i,HeadB);
end;
write('Spisok: ');
WriteList(HeadB);
writeln;
writeln;
write('Hotite dobavit element na proizvolnuiu poziciu? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
write('Vvedite element: ');
readln(buf);
write('Vvedite poziciu: ');
readln(n1);
Add(buf,n1,HeadB);
write('Spisok: ');
WriteList(HeadB);
writeln;
writeln('Kol-vo elementov: ',Kol(HeadB));
end;
writeln;
write('Hotite udalit element na proizvolnoi poziciu? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
write('Vvedite poziciu: ');
readln(n1);
Delete(n1,HeadB);
write('Spisok: ');
WriteList(HeadB);
writeln;
writeln('Kol-vo elementov: ',Kol(HeadB));
readln;
end;
{konec zapolnenia vtorogo spiska}
{vyvodim spiski; predlagaem objedenit}
repeat
clrscr;
write('Spisok A: ');
WriteList(HeadA);
writeln;
write('Spisok B: ');
WriteList(HeadB);
writeln;
writeln;
writeln('Vyberite variant obiedenenia spiskov:');
writeln('1 - prostoe scepleneie');
writeln('2 - obiedenenie po operacii "or"');
write('-> ');
vybor:=readkey;
write(vybor);
until (vybor='1') or (vybor='2') or (vybor=#27);
writeln;
writeln;
case vybor of
'1':begin
C:=Concat(HeadA,HeadB); {scepliem spiski}
write('Spisok C: ');
WriteList(HeadA); {vyvodim poluchennyi}
writeln;
writeln('Kol-vo elementov: ',Kol(HeadA));
readln;
end;
'2':begin
C:=A_OR_B(HeadA,HeadB); {objedeniaem po "ili" (or)}
write('Spisok C: ');
WriteList(C); {vyvodim poluchennyi}
writeln;
writeln('Kol-vo elementov: ',Kol(C));
readln;
end;
#27:halt;
end;
write('Hotite uporiadochit spisok? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
C:=Sort(HeadA); {sortiruem spisok}
write('Spisok: ');
WriteList(C); {vyvodim ego}
readln;
end;
writeln;
write('Hotite invertirovat spisok? [y/n] ');
vybor:=upcase(readkey);
writeln;
if vybor='Y' then
begin
Invert(C); {invertiruem spisok}
write('Spisok: ');
WriteList(C); {vyvodim ego}
end;
writeln;
writeln;
write('Press any key to EXIT... ');
readkey;
end.
uses crt;
type pitem=^item;
item=record
data:integer;
next:pitem;
end;
var A,B,C,headA,headB,headC:pitem;
i,el,kol_poz:integer;
vybor:char;
fl:boolean;
{Добавление в конец списка}
procedure Add(info:integer; var head:pitem);
var p,work:pitem;
begin
new(work);
work^.data:=info;
work^.next:=nil; {sformirovali neobhodimyi element}
if head=nil then head:=work {esli spisok pustoi zapomili ego kak nachalo}
else
begin {inache}
p:=head;
while p^.next<>nil do p:=p^.next; {prohodim do konca spiska}
p^.next:=work; {i vstavliem ssylku na element}
end;
end;
{Освобождение памяти}
procedure Free(var head:pitem);
var p,p0:pitem;
begin
p:=head;
while p<>nil do
begin
p0:=p^.next;
Dispose(p);
p:=p0;
end;
end;
{udalenie poslednego elementa iz spiska nachinaiuschegosia s head}
procedure Delete(var head:pitem);
var p:pitem;
begin
if head<>nil then {esli spisok ne pustoi}
begin
p:=head;
while p^.next^.next<>nil do p:=p^.next; {prohodim do predposlednego}
dispose(p^.next); {udaliem posledlii}
p^.next:=nil; {udaliem ssylku}
end;
end;
{vozvraschaet summu elementov spiska nachinauschegosia s head}
function Sum(head:pitem):integer;
var p:pitem;
all:integer;
begin
p:=head;
all:=0;
while p<>nil do
begin
all:=all+p^.data;
p:=p^.next;
end;
Sum:=all;
end;
{udalenie kazhdogo vtorogo elementa}
procedure DelMod2(head:pitem);
var p,p0,p1:pitem;
k,dx:integer;
begin
p:=head;
k:=0;
dx:=0;
while p<>nil do {prohodim po spisku}
begin
inc(k);
if ((k-dx) mod 2 <> 0) and (p^.next<>nil) then {esli sleduishii element nuzhnyi}
begin
p0:=p^.next;
p1:=p0^.next; {zapomnili ssylki}
Dispose(p0); {ubrali element}
p^.next:=p1; {iskluchili ssylku}
if dx=0 then dx:=1
else dx:=0;
end;
p:=p^.next;
end;
end;
{slianie po operacii "i" vozvraschaet ukazatel na nachalo objedenennogo spiska}
function AandB(head1,head2:pitem):pitem;
function in_(data:integer; head_:pitem):boolean;
{vhodit li element v spisok}
var p:pitem;
begin
p:=head_;
while p<>nil do
if p^.data<>data then p:=p^.next
else
begin
in_:=true;
exit;
end;
in_:=false;
end;
var p1,p2,Rez:pitem;
begin
Rez:=nil;
p1:=head1;
while p1<>nil do
begin {sravnivaem elementy spiskov}
p2:=head2;
while p2<>nil do
begin
if p1^.data=p2^.data then {ischem ravnye elementy}
begin {esli nashli}
if not in_(p1^.data,Rez) then Add(p1^.data,Rez); {esli element esche ne vhodit v spisok
to dobavliem ego}
break;
end;
p2:=p2^.next;
end;
p1:=p1^.next;
end;
AandB:=Rez;
end;
{vyvod elementov spiska}
procedure WriteSpisok(head:pitem);
var p:pitem;
begin
p:=head;
while p<>nil do
begin
write(p^.data,' ');
p:=p^.next;
end;
end;
{peremeshenie elementa data na n pozicii vpered v spiske, nachinaiuschemsia s head}
procedure Move(data,n:integer; var head:pitem);
var p0,p,p1,p2:pitem;
j,k:integer;
begin
if n<=0 then exit;
k:=0;
p:=head;
p0:=nil;
p1:=head^.next;
while p<>nil do {prohodim po spisku}
begin
inc(k);
if p^.data=data then {nashli nuzhnyi element}
begin
if k=1 then head:=p1;
p2:=p;
p:=p0; {iskluchili element}
p^.next:=p1;
for j:=k to k+n-1 do {doshli do nuzhnoi pozicii}
begin
p:=p^.next;
if p^.next=nil then break;
end;
p2^.next:=p^.next;
p^.next:=p2; {vstavili element na poziciu}
exit;
end;
p0:=p;
p:=p^.next;
p1:=p^.next;
end;
end;
function APlusBSort(head1,head2:pitem):pitem;
{prinimaem spiski i sortiruem objedeniaem v odin i sortiruem ego}
function Sort(head:pitem):pitem;
var newh,max,prev,pmax,cur:pitem;
begin
newh:=nil;
while head<>nil do
begin
max:=head;
prev:=head;
cur:=head^.next;
while cur<>nil do
begin
if cur^.data>max^.data then
begin
max:=cur;
pmax:=prev;
end;
prev:=cur;
cur:=cur^.next;
end;
if max=head then head:=head^.next
else pmax^.next:=max^.next;
max^.next:=newh; newh:=max;
end;
Sort:=newh;
end;
var rez,p:pitem;
begin
APlusBSort:=nil;
if head1<>head2 then
begin
rez:=nil;
p:=head1;
while p^.next<>nil do
begin
Add(p^.data,rez);
p:=p^.next;
end;
p:=head2;
while p^.next<>nil do
begin
Add(p^.data,rez);
p:=p^.next;
end;
APlusBSort:=Sort(Rez);
end;
end;
procedure Out;
{objedenennyi vyvod}
begin
write(' A: ');
WriteSpisok(HeadA);
writeln;
write(' B: ');
WriteSpisok(HeadB);
writeln;
end;
begin
TextBackGround(Lightblue);
clrscr;
TextColor(white);
randomize;
HeadA:=nil;
for i:=1 to 15 do Add(random(20)-10,HeadA);
HeadB:=nil;
for i:=1 to 15 do Add(random(20)-10,HeadB);
writeln(' Sozdanno 2 spiska');
Out;
write(' Press any key to Continue...');
readkey;
fl:=false;
repeat
repeat
clrscr;
writeln(' 1 - Summa elementov');
writeln(' 2 - Udalenie poslednego elementa');
writeln(' 3 - Udalenie kazhdogo 2-ogo elementa');
writeln(' 4 - Peremeschenie elementa na N pozicii vpered');
writeln(' 5 - Obschie elementy spiskov');
writeln(' 6 - Objedenenie spiskov v odin uporiadochennyi');
writeln(' ESC - EXIT');
write(' -> ');
vybor:=readkey;
if ((vybor in ['1'..'6'])=false) and (vybor<>#27) then
begin
textcolor(red);
write('Nepravilnyi vybor!');
readkey;
textcolor(white);
end
else if vybor<>#27 then write(vybor);
until (vybor in ['1'..'6']) or (vybor=#27);
writeln;
case vybor of
'1':begin
Out;
writeln(' Summa A=',Sum(HeadA));
writeln(' Summa B=',Sum(HeadB));
end;
'2':begin
writeln(' Do udalenia: ');
Out;
Delete(HeadA);
Delete(HeadB);
writeln(' Posle udalenia: ');
Out;
end;
'3':begin
writeln(' Do udalenia: ');
Out;
DelMod2(HeadA);
DelMod2(HeadB);
writeln(' Posle udalenia: ');
Out;
end;
'4':begin
writeln(' Do peremeschenia: ');
Out;
write(' Vvedite element: ');
readln(el);
write(' Kol-vo pozicii: ');
readln(kol_poz);
Move(el,kol_poz,HeadA);
Move(el,kol_poz,HeadB);
writeln(' Posle peremeschenia: ');
Out;
end;
'5':begin
writeln(' Spiski: ');
Out;
HeadC:=nil;
HeadC:=AandB(HeadA,HeadB);
write(' Obschie elementy: ');
WriteSpisok(HeadC);
writeln;
fl:=true;
end;
'6':begin
writeln(' Spiski: ');
Out;
writeln(' Poluchennyi spisok: ');
write(' ');
HeadC:=nil;
HeadC:=APlusBSort(HeadA,HeadB);
WriteSpisok(HeadC);
writeln;
fl:=true;
end;
end;
if vybor<>#27 then
begin
write(' Press any key to Continue... ');
readkey;
end;
until vybor=#27;
Free(HeadA);
Free(HeadB);
if fl then Free(C);
end.
|
|
Всего записей: 613 | Зарегистр. 06-01-2004 | Отправлено: 19:02 03-06-2010 | Исправлено: docck, 12:55 08-06-2010 |
|
