|
|
|
1. Tehnica "GREEDY
1.1 Problema rucsacului
1.2 Problema comis-voiajorului
Problema rucsacului:
O persoana are un rucsac cu care poate transporta o greutate maxima G. Persoana are la dispozitie n obiecte si cunoaste pentru fiecare obiect greutatea si castigul care se obtine in urma transportului sau la destinatie. Se cere sa se precizeze ce obiecte trebuie sa transporte persoana in asa fel incat castigul sa fie maxim. Se considera posibilitatea in care un obiect poate fi taiat in mai multe bucati ( problema continua a rucsacului)
Program rucsac;
Type vector=array[1..9] of real;
var c,g,ef: vector;
n,i,man1: integer;
gv, man, castig:real;
inv: boolean;
ordine: array[1..9] of integer;
begin
write('greutatea ce poate fi transportata=');
readln(gv);
write('numar de obiecte=');
readln(n);
for i:=1 to n do
begin
write('c[',i,']=');
readln(c[i]);
write('g[',i,']=');
readln(g[i]);
ordine[i]:=i;
ef[i]:=c[i]/g[i];
end;
repeat
inv:=false;
for i:=1 to n-1 do
if ef[i]<ef[i+1] then
begin
man:=ef[i];
ef[i]:=ef[i+1];
ef[i+1]:=man;
man:=c[i];
c[i]:=c[i+1];
c[i+1]:=man;
man:=g[i];
g[i]:=g[i+1];
g[i+1]:=man;
inv:=true;
man1:=ordine[i];
ordine[i]:=ordine[i+1];
ordine[i+1]:=man1;
end;
until not inv;
castig:=0;
i:=1;
while (gv>0) and (i<=n) do
begin
if gv>g[i] then
begin
writeln('obiectul ', ordine[i],' ',1);
gv:=gv-g[i];
castig:=castig+c[i];
end
else
begin
writeln('obiectul ', ordine[i],' ',gv/gv[i]:1:2);
castig:=castig*gv/g[i];
gv:=0;
end;
i:=i+1;
end;
writeln('castig total=',castig:3:2)
end.
Fie G=(X,Γ) un graf neorientat in care 2 varfuri distincteale grafului sunt unite intre ele. Sa se determine un ciclu care sa indeplineasca simultan urmatoarele conditii:
sa treaca prin toate nodurile grafului;
costul drumului sa fie minim.
Acestei probleme i se poate asocia urmatoarea explicatie practica: un comis-voiajor pleaca dintr-un oras, trebuie sa viziteze un numar de orase si sa se intoarca in orasul de plecare cu efort minim (de exemplu de timp, caz in care costul unei muchii a grafului reprezinta timpul necesar comis-voiajorului pentru a ajunge dintr-un oras in altul).
Program cv;
type matrice=array [1..9,1..9] of integer;
vector=array[1..9] of integr;
var a: matrice;
s: vector;
n,i,j,v,v1,v2,min,cost: integer;
begin
write('n=');readln(n);
for i:=1 to n do
for j:=i+1 to n do
begin
write('a[', i,', ',j,']=');
readln(a[i,j]);
end;
for i:= 1 to n do
begin
s[i]:=0;
a[i,i]:=0;
end;
write(' nodul de pornire este=');
readln(v);
s[v]:=1;
v2:=v;
cost:=0;
writeln(v);
for i:=1 to n-1 do
begin
min:=30000;
for j:=1 to n do
if (a[v2,j]<>0) and (s[j]=0) and (a[v2,j]<min) then
begin
min:=a[v2,j];
v1:=j;
end;
v2:=v1;
s[v2]:=1;
cost:=cost+min;
writeln(v1);
end;
cost:=cost+a[v2,v];
writeln(v);
writeln('cost total=',cost);
end.
2.Programare dinamica
2.1 Subsir crescator de lungime maxima
2.2 Determinarea drumurilor de cost minim intr-un graf
Subsir crescator de lungime maxima
Se considera un vector cu n elemente intregi. Se cere sa se tipareasca cel mai lung subsir crescator al acestuia.
Program sir;
type vector=array [1..20] of integer;
var v,l:vector;
n,i, k,max,t: integer;
begin
write ('n=');
readln(n);
for i:=1 to n do
begin
write('v[',i,']=');
readln(v[i]);
end;
l[n]:=1;
for k:=n-1 downto 1 do
begin
max:=0;
for i:=k+1 to n do
if (v[i]>=v[k]) and (l[i]>max) then
max:=l[i];
l[k]:=1+max;
end;
max:=l[1];
t:=1;
for k:=1 to n do
if l[k]>max then
begin
max:=l[k];
t:=k;
end;
writeln('lungime maxima:',max);
writeln(v[t]);
for i:=t+1 to n do
if (v[i]>=v[t]) and (l[i]=max-1) then
begin
writeln(v[i]);
max:=max-1;
end;
end.
Determinarea drumurilor de cost minim intr-un graf
Se considera un graf orientat, dat programului printr-o matrice A, numita matricea atasata grafului. Se cere ca pentru fiecare pereche de varfuri (i,j) sa se tipareasca lungimea drumului minim de la i la j.
Program dm;
type matrice=array[1..9,1..9] of integer;
var a:mat;
i,j,k,n: integer;
begin
write('n=');
readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('a[',i,',',j,']=');
readln(a[i,j]);
end;
for k:=1 to n do
for i:= 1 to n do
for j:=1 to n do
if a[i,j]>a[i,k]+a[k,j] then
a[i,j]:= a[i,k]+a[k,j];
for i:=1 to n do
begin
for j:=1 to n do
write(' ',a[i,j],' ');
writeln;
end;
end.
3.Backtracking
3.1 Generarea combinarilor
3.2 Produsul cartezian a N multimi
Generarea combinarilor
Se citesc n,p numere naturale, cu n mai mare sau egal cu p . Se cere sa se genereze toate submultimile cu p elemente ale multimii . Doua submultimi se considera egale, daca si numai daca au aceleasi elemente, indiferent de ordinea in care acestea apar.
Program combinari;
type stiva=array[1..100] of integer;
var st:stiva;
n,k,p: integer;
as,ev: boolean;
procedure init(k: integer;var st:stiva);
begin
st[k]:=0;
end;
procedure succesor(var as: boolean; var st: stiva; k: integer);
begin
if st[k]<n-p+k then
begin
st[k]:=st[k]+1;
as:=true;
end
else
as:=false;
end;
procedure valid(var ev:boolean; st:stiva;k:integer);
var i: integer;
begin
ev:=true;
for I:=1 to k-1 do
if st[k]=st[i] then
ev:=false;
if k>1 then
if st[k]<st[k-1] then
ev:=false;
end;
function solutie(k: integer): boolean;
begin
solutie:=(k=p)
end;
procedure tipar;
var i: integer;
begin
for I:=1 to p do
write(st[i]);
writeln;
end;
begin
write('n=');
readln(n);
write('p=');
readln(p);
k:=1;
init(k,st);
while k>0 do
begin
repeat
succesor(as,st,k);
if as then valid(ev, st,k)
until (not as) or (as and ev);
if as then
if solutie (k) then tipar
else
begin
k:=k+1;
init(k,st);
end
else
k:=k-1;
end;
end.
Produsul cartezian a N multimi
Se dau multimile A1= ; A2= ; ..; An=
Se cere produsul cartezian A1xA2x..xAn=
Program pcartez;
type stiva=array[1..100] of integer;
var st: stiva;
i,n,k: integer;
as,ev:boolean;
procedure init(k:integer; var st:stiva);
begin
st[k]:=0;
end;
procedure succesor(var as:boolean; var st:stiva; k:integer);
begin
if st[k]<a[k] then
begin
st[k]:=st[k]+1;
as:=true;
end
else as:=false;
end;
procedure valid(var ev: boolean; st:stiva;k:integer);
var i:integer;
begin
ev:=true;
end;
function solutie( k:integer): boolean;
begin
solutie:=(k=n);
end;
procedure tipar;
var i:integer;
begin
for i:=1 to n do
write(st[i]);
writeln;
end;
begin
write(' numarul de multimi=');
readln(n);
for i:=1 to n do
begin
write('a[',i,']=');
readln(a[i]);
end;
k:=1;
init(k,st);
while k>0 do
begin
repeat
succesor(as,st,k);
if as then valid(ev,st,k)
until (not as) or (as and ev);
if as then
if solutie(k) then tipar
else
begin
k:=k+1;
init(k,st);
end
else k:=k-1;
end;
end.
4. Branch&Bound
4.1 Problema patratului
4.2 Lampa lui Dario Uri
Problema patratului
Se considera un patrat cu n*n casute. Fiecare casuta contine un numar natural intre 1 si n*n-2. Doua casute sunt ocupate cu numarul 0. Fiecare numar natural, diferit de 0, apare o singura data in cadrul patratului. Stiind ca 0 isi poate schimba pozitia cu orice numar natural aflat deasupra, la dreapta, la stanga sau jos, in raport cu pozitiain care se afla numarul 0, se cere sa se precizeze sirul de mutari prin care se poate ajunge de la o configuratie initiala la configuratia finala. Se cere de asemenea ca acest sir sa fie optim, in sensul ca trebuie sa se ajunga la configuratia finala intr-un numar minim de mutari.
Program bb;
Uses crt;
type patrat=array[1..4,1..4] of byte;
ref=^inr;
inr=record
t:patrat;
g,h:byte;
tata,ul,u:ref;
end;
var n,i,j: integer;
a,b:patrat;
io,so,ic,sc,il,sv,v,ac,ao,dd:ref;
gasit, apo, apcl,ff:boolean;
e:char;
procedure traseaza(v:ref);
var I,j:integer;
begin
if v<>ni1 then
begin
traseaza(v^.tata);
repeat
e:=readkey
until e<>' ';
for I:=1 to n do
begin
for j:=1 to n do
write(v^.t[i,j]);
writeln;
end;
writeln;
end;
end;
function h(a,b:patrat;n:integer):byte;
var I,j,k,l,s:byte;
begin
s:=0;
for I:=1 to n do
for j:=1 to n do
for l:=1 to n do
for k:=1 to n do
if (b[I,j]=a[l,k])and(b[I,j]<>0) then
s:=s+abs(I-1)+abs(j-k);
h:=s;
end;
procedure expand(c:ref; var il,sl:ref);
var I,j,k,l1,cl,l2,c2:byte;
f:patrat;
as:boolean;
d:ref;
begin
k:=0;
for I:=1 to n do
for j:=1 to n do
if c^.t[I,j]=0 then
if k=0 then
begin
l1:=i;
c1:=j;
k:=1;
end
else
begin
l2:=i;
c2:=j;
end;
il:=nil;
sl:=nil;
for k:=1 to 8 do
begin
f:=c^.t;
case k of
1: if l1>1 then
begin
f[l1,c1]:=f[l1-1,c1];
f[l1-1,c1]:=0
end;
2: if c1<n then
begin
f[l1,c1]:=f[l1,c1+1];
f[l1,c1+1]:=0;
end;
3: if l1<n then
begin
f[l1,c1]:=f[l1+1,c1];
f[l1+1,c1]:=0;
end;
4: if c1<1 then
begin
f[l1,c1]:=f[l1,c1-1];
f[l1,c1-1]:=0;
end;
5: if l2>1 then
begin
f[l2,c2]:=f[l2-1,c2];
f[l2-1,c2]:=0;
end;
6: if c2<n then
begin
f[l2,c2]:=f[l2,c2+1];
f[l2,c2+1]:=0;
end;
7: if l2<n then
begin
f[l2,c2]:=f[l2+1,c2];
f[l2+1,c2]:=0;
end;
8: if c2>1 then
begin
f[l2,c2]:=f[l2,c2-1];
f[l2,c2-1]:=0;
end;
end(case);
as:=false;
for I:=1 to n do
for j:=1 to n do
if c^.t[i,j]<>f[i,j] then as:=true;
if as then
begin
new(d);
d^.tata:=c;
d^.g:=c^.g+1;
d^.t:=h;
d^.h:=h(d^.t,b,n);
d^.ul:=nil;
if il=nil then il:=d;
sl:=d
else
begin
sl^.ul:=d;
sl:=d
end
end;
end;
procedure selopen(var io,so,ic,sc,v:ref);
var d,e:ref;
m1,m:byte;
begin
m:=io^.g+io^.h;
m1:=io^.h;
v:=io;
d:=io;
while d<>nil do
begin
if (m>d^.g+ d^.h) or ((m=d^.g+ d^.h) and (m1> d^.h)) then
begin
m:= d^.g+ d^.h;
m1:= d^.h;
v:=d;
end;
d:=d^.u
end;
if io=so then
begin
io:=nil;
so:=nil
end
else
if io=v then
io:=io^.u;
else
begin
d:=io;
while d^.u<>v do
d:=d^.u;
if so=v then
begin
so:=d;
so^.u:=nil
end
else d^.u:=v^.u;
end;
v^.u:=nil;
if ic=nil then
begin
ic:=v;
sc:=v
end
else
begin
sc^.u:=v;
sc:=v
end;
for I:=1 to n do
begin
for j:=1 to n do
write(v^.t[i,j]);
writeln;
end;
writeln;
writeln('g',v^.g,'h',v^.h);
end;
procedure apopcl(il,io,ic:ref;var apo,apc:boolean; var ao,ac:ref);
var d:ref;
i,j:byte;
begin
d:=io;
apo:=false;
while(d<>nil) and (not apo) do
begin
d:=io;
apo:=false;
for I:=1 to n do
for j:=1 to n do
if d^.t[i,j]<>il^.t[i,j] then
apo:=false
if not apo then
ao:=d;
d:=ic;
apc:=false;
if not apc then
d:=d^.u
end;
if apc then
ac:=d;
end;
procedure sclose(var icl,scl,acl:ref);
var d:ref;
begin
if acl=icl then
icl:=icl^.u
else
begin
d:=icl;
while d^.u<>acl do
d:=d^.u;
if acl=scl then
begin
d^.u:=nil;
scl:=d
end
else
d^.u:=acl^.u
end;
end;
procedure inclop(var iop,sop,il:ref);
var:ref;
begin
if iop<>nil then
begin
il^.u:=nil;
il^.h:=h(il^.t,b,n);
sop^.u:=il;
sop:=il
end
else
begin
il^.u:=nil;
il^.h:= h(il^.t,b,n);
iop:=il;
sop:=il
end;
end;
begin
write('n=');
readln(n);
writeln('introduceti configuratia initiala');
for I:=1 to n do
for j:=1 to n do
begin
write('a[',i,',',j,']=');
readln(a[i,j])
end;
writeln('introduceti configuratia finala:');
for I:=1 to n do
for j:=1 to n do
begin
write('b[',i,',',j,']=');
readln(b[i,j]);
end
new(io);
so:=io;
io^.t:=a;
io^.g:=0;
io^.tata:=nil;
io^.h:=h(a,b,n);
io^.u:=nil;
ic:=nil;
sc:=nil;
gasit:=false;
while(io<>nil) and (not gasit) do
begin
selopen(io,so,ic,sc,v);
if h(v^.t,b,n)=0 then
begin
writeln('solutie-apasati o tasta');
traseaza (v);
gasit:=true;
end
else
begin
expand(v,il,sl);
while il<>nil do
begin
ff:=false;
il^.g:= v^.g+1;
apopcl(il,io,ic,apo,apcl,ao,ac);
if apo or apcl then
case apo of
true:
if il^.g< ao^.g then
begin
ao^.g:= il^.g;
ao^.tata:=v;
end
else ff:=true;
false:
if il^.g< ac^.g then
begin
ac^.g:= il^.g;
ac^.tata:=v;
sclose(ic,sc,ac);
inclop(io,so,ac);
end
else ff:=true;
end
else
begin ao^.tata:=v;
inclop(io,so,il);
end;
end;
end;
end.
Lampa lui Dario Uri
Se da un patrat cu n*x butoane luminoase.Initial, toate aceste butoane sunt stinse. Butoanele se pot aprinde, respectiv stinge, prin apasare. Mai exact, prin apasarea unui buton, atat el cat si butoanele vecine de pe orizontala si verticala isi schimba starea( trec din starea aprins in starea stins si invers).
Se cere sirul minim de mutari prin care toate butoanele pot fi aprinse.
program lampa;
uses crt;
type patrat=array[1..3,1..3] of byte;
ref=^inr;
inr=record
t:patrat;
g,h:byte;
tata,ul,u:ref
end;
var n,i,j:integer;
a,b:patrat;
io,so,ic,sc,il,sl,v,ac,ao,dd:ref;
gasit,apo,apcl,ff:boolean;
e:char;
procedure traseaza (:ref);
var i,j:integer;
begin
if v<>nil
then
begin
traseaza(v^.tata);
repeat
e:=readkey
until e<>' ';
for i:=1 to n do
begin
for j:=1 to n do
write (v^.t[i,j]);
writeln
end;
writeln
end
end;
function h(a:patrat; n:integer):byte;
var i,j,k,s:byte;
begin
s:=0;
for i:=1 to n do
for j:=1 to n do
if a[i,j]=0
then
s:=s+1;
case s of
0 : h:=0;
1..5 : h:=1;
6..10 : h:=2;
else
h:=3;
end;
end;
procedure expand(c:ref; var il,sl:ref);
var i,j,k,l1,c1,l2,c2:byte;
f:patrat;
d:ref;
begin
for i:=1to n do
for j:= 1 to n do
begin
f:=c^.t;
f[i,j]:=(c^.t[i,j]+1) mod 2;
if i>1
then
f[i-1,j]:=(c^.t[i-1,j]+1) mod 2;
if i<n
then
f[i+1,j]:=(c^.t[i+1,j]+1) mod 2;
if j>1
then
f[i,j-1]:=(c^.t[i,j-1]+1) mod 2;
if j<n
then
f[i,j+1]:=(c^.t[i,j+1]+1) mod 2;
new(d);
d^.tata:=c;
d^.g:c^.g+1;
d^.t:=f;
d^.h:=h(d^.t,n);
d^.ul:=nil;
if il=nil
then
begin
il:=d;
sl:=d
end
else
begin
sl^.ul:=d
sl:=d
end
end
end;
procedure selopen(var io,so,ic,sc,v:ref);
var d,e:ref;
m1,m:byte;
begin
m:=io^.g+io^.h;
m1:=io^.h;
v:=io;
d:=io;
while d<>nil do
begin
if (m>d^.g+d^.h) or ((m=d^.g+d^.h) and (m1>d^.h))
then
begin
m:=d^.g+d^.h;
m1:=d^.h;
v:=d
end;
d:=d^.u
end;
if io=so
then
begin
io:=nil;
so:=nil
end
else
if io=v
then
io:=io^.u
else
begin
d:=io;
while d^.u<>v do
d:=d^.u;
if so=v
then
begin
so:=d;
so^.u:=nil;
end
else
d^.u:=v^.u;
end
v^.u:=nil;
if ic=nil
then
begin
ic:=v;
sc:=v
end
else
begin
sc^.u:=v;
sc:=v
end;
for i:= 1 to n do
begin
for j:=1 to n do
write(v^.t[i,j]);
writeln
end;
writeln;
writeln('g',v^.g,'h',v^.h);
end;
procedure apopcl(il,io,ic:ref;var apo,apc:boolean;var ao,ac:ref);
var d:ref;
i,j:byte;
begin
d:=io;
apo:=false;
while (d<>nil) and (not apo) do
begin
apo:=true;
for i:=1 to n do
for j:=1 to n do
if d^.t[i,j]<>il^.t[i,j]
then
apo:=false;
if not apo
then
d:=d^.u
end;
if apo
then
ao:=d;
d:=ic;
apc:=false;
while (d<>nil) and (not apc) do
begin
apc:=true;
for i:=1 to n do
for j:=1 to n do
if d^.t[i,j]<>il^.t[i,j]
then
apc:=false;
if not apc
then
d:=d^.u
end;
procedure sclose(var icl,scl,acl:ref);
var d:ref;
begin
if acl=icl then
icl:=icl^.u;
else begin
d:=icl;
while d^.u<>acl do
d:=d^.u;
if acl=scl then
begin
d^.u:=nil;
scl:=d
end
else
d^.u;=acl^.u
end
end;
procedure inclop(var iop,sop,il:ref);
var d:ref;
begin
if iop<>nil then
begin
il^.u:=nil;
il^.h:=h(il^.t,n);
sop^.u:=il;
sop:=il
end
else
begin
il^.u:=nil;
il^.h:=h(il^.t,n);
iop:=il;
sop;=il;
end;
end;
begin
write('n=');
readln(n);
for i:=1 to n do
for j:=1 to n do
a[i,j]:=0;
new(io);
so:=io;
io^.t:=a;
io^.g:=0;
io^.tata:=nil;
io^.h:=h(a,n);
io^.u:=nil;
ic:=nil;
sc:=nil;
gasit:=false;
while (io<>nil) and (and gasit) do
begin
seleopen(io,so,ic,sc,v);
if h(v^.t,n)=0 then
begin
writeln('solutie-apsati o tasta');
traseaza(v);
gasit:=true
end
else
begin
expand(v,il,sl);
while il<>nil do
begin
ff:=false;
il^.g:=v^.g+1;
apopcl(il,io,ic,apo,apcl,ao,ac);
if apo or apcl then
case apo of
true:if il^.g<ao^.g then
begin
ao^.g:=il^.g;
ao^.tata:=v
end
else
ff:=true;
false: if il^.g<ac^.g then
begin
ac^.g:=il^.g;
ac^.tata:=v;
sclose(ic,sc,ac);
inclop(io,so,ac)
end
else ff:=true;
end
else begin
il^.tata:=v;
inclop(io,so,il);
end;
dd:=il;
il:=il^.ul;
if ff then
dispose(dd);
end;
end
end
end.
5.Metode euristice:
5.1Determinarea maximului unei functii
5.2Repartitia apartamentelor
1. Fie data o functie f:[a,b]->R, se cere determinarea maximului M pe acest interval.
O procedura euristica de rezolvare consta in urmatoarele:
impartim intervalul [a,b] in n parti egale: h=(b-a)/n;
Determinam punctele de maxim local ca fiind acele puncte xi=a+hi pentru care f(xi-1)<=f(xi)>=f(xi+1) si il alegem pe cel care produce o valoare maxima globala pentru functia f:
Program Maxf;
Function Pow(x:real;n:integer):real;
T:real;
I:integer;
Begin
T:=1;
For I:=1 to n do
T:=t*x;
Pow:=t;
End;
Function f(x:real):real;
Begin
F:=pow(x,4)-7*pow(x,3)+14*pow(x,2)-8*x;
End;
Var I,n :integer;
a,b, tp,tc, tu,pm,h,m:real;
begin
write('intervalul de studiu: ');readln(a,b);
write('Numarul de subintervale de studiu: );readln(n);
h:=(b-a)/n;I:=1;
pm:=a;
m:=f(a);tp:=m;
tc:=f(a+h*I);
while I<n do
begin
tu:=f(a+(I+1)*h);
if(tp<=tc)and(tu<=tc) then
begin
if tc>m then
begin
m:=tc;
pm:=a+h*I;
end;
end;
tp:=tc; tc:=tu; I;=I+1;
end;
if f(b)>m then
begin
m:=f(b); pm:=b;
end;
write('Maximul functiei pe intervalul dat: f(',pm:7:2,')=',m:7:2;
end.
2.Repartitia apartamentelor
Un apartament de n apartamente trebuie repartizate la n persoane, fiecare persoana primind un singur apartament iar fiecare apartament nu se poate repartiza simultan mai multor persoane. Fiecare persoana prezinta o lista de prederinte pentru anumite apartamente. Repartizati cele n apartamente astfel satisfacerea cerintelor sa fie maxima.
Program Apart;
Type
Ptr=^nod;
Nod=record
Pf:integer;
Np:integer;
Next:ptr;
End;
Persoana=record
Servit:boolean;
O:integer;
Adr:ptr;
End;
Pers=array[1..100] of persoana;
Procedure Adaug(var p:Pers;I,pref,niv:integer);
Var
Temp,nou:ptr;
Begin
New(nou);
P[i].o:=p[i].o+1;
Nou^.pf:=pref;
Nou^.np:=niv;
Nou^.next:=Nil;
If p[i].adr=Nil then
P[i].adr:=nou
Else
Begin
Temp:=p[i].adr;
While temp^.next<>Nil do
begin
Temp:=temp^.next;
Temp^.next:=nou;
End;
End;
Function Ins(var p:Pers;k,n,ch:integer):integer;
Var
J,I:integer;
Temp:ptr;
Begin
J:=0;
For I:=1 to n do
If(notp[i].servit) and (k<>I) then
Begin
Temp:=p[i].adr;
While temp<>Nil do
Begin
If temp^.pf=ch then
J:=j+temp^.np;
Temp:=temp^.next
End;
End;
Ins:=j;
End;
Procedure Minim(var p: Pers;n:integer;var im:integer);
Var
Prim:ptr;
I,j,m1,m2,m3,v:integer;
Begin
J:=1;
While j<=n do
If (not p[j].servit) and (p[j].o<>0) then
Begin
M1:=p[j].o;
M2:=prim^.np;
M3:=ins(p,j,n,prim^.nf);
Im:=j;
J:=n+1;
End
Else j;=j+1;
J:=im;
For I:=j+1 to n do
Begin
Prim:=p[i].adr;
If(not p[i].servit) and (p[i].o<>0) then
If p[i].o<m1 then
Begin
M1:=p[i].o;
M2:=prim^.np;
M3:=ins(p,I,n,prim^.pf);
Im:=I;
End
Else
If p[i].o=m1 then
If prim^.np>m2 then
Begin
M1:=p[i].o;
M2:=prim^.np;
M3:=ins(p,I,n,prim^.nf);
Im:=I
End
Else
If prim^.np=m2 then
Begin
Prim:=p[i].adr;
V:=ins(p,I,n,prim^.pf);
If v<m3 then
Begin
M1:=p[i].o;
M2:=prim^.np;
M3:=ins(p,I,n,prim^.pf);
Im:=I
End;
End
End;
Procedure Elib(var p:Pers;n,ch:integer);
Var
Prim, trecut:ptr;
I:integer;
Sf:boolean;
Begin
For I:=1 to n do
If not p[i].servit then
If p[i].adr<>Nil then
Begin
If prim^.next=Nil then p[i].adr:=nil
Else p[i].adr:=prim^.next;
P[i].o:=p[i].o-1;
Dispose(prim); sf:=true
End;
While (not sf) and (prim^.next<>Nil) do
Begin
Trecut:=prim; prim:=prim^.next;
If prim^.pf=ch then
Begin
P[i].o:=p[i].o-1;
Trecut^.next:=prim^.next;
Dispose(prim);sf:=true
End
End
End
End;
Var
P:Pers;
A:array[1..100] of integer;
I,j,pref,n,im,St:integer;
Temp:ptr;
Sf:boolean;
Begin
Write('Nr de apartamente/persoane: ');readln(n);St:=0;
For I:=1 to n do
Begin
P[i].o:=0;p[i].servit:=false;p[i].adr:=Nil;a[i]:=0;
Writeln('Preferintele solicitantului ',I;2,'(ctrl/z pt sfarsit)');
J:=1;
Write(j:2,':');read(pref);
While j<=n do
If not eof then
Begin
If eoln then readln;
Adaug(p,I,pref,n-j+1);
J:=j+1;
If j<=n then
Begin
Write(j:2,':');
Read(pref);end;end
Else j:=n+1
End;
For I:=1 to n do
Begin
Im:=n+1;
Minim(p,n,im);
If im<=n then
Begin
Temp:=p[im];a[temp^.pf]:=im;St:=St+temp^.np;
P[im].servit:=true;
Elib(p,n,temp^.pf)
End
End;
J:=1;I:=1;
While j<=n do
Begin
If not p[j].servit then
Begin
Sf:=false;
While (I<=n) and (not sf) do
Begin
If a[i]=0 then
Begin
A[i]:=j;
P[j].servit:=true;
Sf:=true;
End;
I:=I+1
End
End;
J:=j+1
End;
Writeln('repartizarea apartamentelor:');
For I:=1 to n do writeln('apartamentul ',I:2,'persoana', a[i]:2);
Writeln('Grad de multumire: ', St)
End.
