Programozási feladat 3.
Algoritmusok, gráfelméleti algoritmusok

Szélességi bejárás

Needs["Combinatorica`"];
Needs["GraphUtilities`"]; 
(*A Combinatorica csomag betöltése szükséges, a példagráfok és a ToAdjacencyLists[graph] és a V[graph] parancsok miatt*)

G=(V,E) gráf, célunk: minden élen végigmenni.
Olyan bejárási sorrendet akarunk, ami szerint csak akkor foglalkozunk a kezdőponttól távolabbi csúcsokkal, ha a közelieket már mind megnéztük. Megnézzük az első csúcsot, annak minden szomszédját, majd azok minden szomszédját, stb.
Algoritmus:
Egy sort (FIFO, vagyis First In First Out listát) alkalmaz, amibe beletesszük az éppen látogatott csúcsot, hogy majd a megfelelő időben a szomszédaira is sort keríthessünk.
Vesszük a sor elején levő x csúcsot, ezt töröljük a sorból, meglátogatjuk azokat az y szomszédait, amelyeket még nem láttunk, majd ezeket a sor végére tesszük.
A bejárva[1:n] tömb szolgál a már látogatott csúcsok megjelölésére.

Szb1[g_Graph,csucs_Integer]:=
Module[{v,bejarva=Table[0,{V[g]}],sor={csucs},szulo=Table[i,{i,V[g]}],szam=1,szomszedlista=ToAdjacencyLists[g]},
bejarva[[csucs]]=szam;
szam++;
While[sor≠ {},
v=First[sor];
sor=Rest[sor];
Scan[If[bejarva[[#]]==0,bejarva[[#]]=szam++;
szulo[[#]]=v;
AppendTo[sor,#]]&,szomszedlista[[v]]
]
];
{bejarva,szulo}]

Szb1[Wheel[7],6]

Szb1[PetersenGraph,5]

Szb1 esetén az első listában az szerepel, hogy hanyadjára látogattuk meg a csúcsot, a másodikban pedig az, hogy őt melyik csúcsból értük el.
Szb2 annyival tesz többet, hogy ezt a listát úgy rendezi be, hogy a csúcsok sorrendjét lássuk, szintén a második listában pedig a megfelelő csúcsok “szüleit”.

Szb2[g_Graph,csucs_Integer]:=Module[{bejarva=Szb1[g,csucs][[1]],szulo=Szb1[g,csucs][[2]], bejarva2=Table[0,{V[g]}],szulo2=Table[0,{V[g]}]},
Table[Table[If[bejarva[[j]]==i,bejarva2[[i]]=j],{j,1,V[g]}],{i,1,V[g]}];
Table[szulo2[[i]]=szulo[[bejarva2[[i]]]],{i,1,V[g]}];
{bejarva2,szulo2}]

Szb2[Wheel[7],6]

Szb2[PetersenGraph,5]

Ezeket használjuk a bejárás kirajzolásánál, valamint az AnimateGraph függvényt, mellyel csúcsokat és éleket lehet animálni.

animatecsucs[g_Graph,kcsucs_Integer]:=AnimateGraph[g,Szb2[g,kcsucs][[1]]];
animateel[g_Graph,kcsucs_Integer]:=AnimateGraph[g,Table[{Szb2[g,kcsucs][[2]][[i]],Szb2[g,kcsucs][[1]][[i]]},{i,1,V[g]}]];
TableForm[{{animatecsucs[PetersenGraph,6],animateel[PetersenGraph,6]}}]

Saját animáció: csúcsok és élek együtt animálva.

Csucslista[g_Graph,cs_Integer]:=Module[{m2=Table[Szb2[g,cs][[1]][[1;;i]],{i,1,V[g]}]},Table[AppendTo[m2[[j]],VertexColor->Blue],{j,1,V[g]}]];
Ellista[g_Graph,cs_Integer]:=Module[{n2=Table[Table[{Szb2[g,cs][[2]][[i]],Szb2[g,cs][[1]][[i]]},{i,1,V[g]}][[1;;j]],{j,1,V[g]}]},Table[AppendTo[n2[[j]],{EdgeColor->Green,EdgeStyle->Thick}],{j,1,V[g]}]];
Szelessegi[g_Graph,cs_Integer]:=Module[{m=Csucslista[g,cs],n=Ellista[g,cs]},Manipulate[ShowGraph[g,List[m[[a]],n[[a]]],VertexNumber->On],{{a,1,"Lépésszám"},1,V[g],1}]]

Szelessegi[PetersenGraph,6]

A színek is megválaszthatók, néhány példa:

Csucslista2[g_Graph,cs_Integer,szin1_]:=Module[{m2=Table[Szb2[g,cs][[1]][[1;;i]],{i,1,V[g]}]},Table[AppendTo[m2[[j]],VertexColor->szin1],{j,1,V[g]}]];
Ellista2[g_Graph,cs_Integer,szin2_]:=Module[{n2=Table[Table[{Szb2[g,cs][[2]][[i]],Szb2[g,cs][[1]][[i]]},{i,1,V[g]}][[1;;j]],{j,1,V[g]}]},Table[AppendTo[n2[[j]],{EdgeColor->szin2,EdgeStyle->Thick}],{j,1,V[g]}]];
Szelessegi2[g_Graph,cs_Integer,szin1_,szin2_]:=Module[{m=Csucslista2[g,cs,szin1],n=Ellista2[g,cs,szin2]},Manipulate[ShowGraph[g,List[m[[a]],n[[a]]],VertexNumber->On,ImageSize->400],{{a,1,"Lépésszám"},1,V[g],1}]]

TableForm[{{Szelessegi2[ExactRandomGraph[5,8],5,Red,Yellow],Szelessegi2[GeneralizedPetersenGraph[7,2],6,Orange,Purple]},{Szelessegi2[Wheel[8],2,Purple,Blue],Szelessegi2[RandomTree[10],5,Darker[Green],Lighter[Blue]]}}]

Irányított gráfra a szélességi bejárás:

TableForm[{{Szelessegi[DeBruijnGraph[2,3],2],Szelessegi[OrientGraph[CompleteGraph[3,5]],3]}}]

Mélységi bejárás

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

A mélységi bejárás (Depth First Search) egy kezdőpontból kiindulva addig megy tovább irányított élek mentén (ha irányítatlan egy él, akkor mindkét irányban irányítottnak veszi), amíg tudunk be nem járt csúcsba menni. Ha már nem tudunk, akkor visszalépünk az út utolsó előtti pontjáig, és onnan próbálunk másfelé továbbmenni. Ezután még eggyel visszamegyünk és így tovább. Ezzel minden csúcsát bejárhatjuk a gráfnak.
Az algoritmus:
mb(v):
bejarva[v]:=igaz
minden (v,w)∈E, ha bejarva[w]=hamis, akkor mb(w )

DFS[v_Integer]:=
(AppendTo[bejarva,v];
Scan[(If[szulo[[#]]==0,AppendTo[elek,{v,#}];
szulo[[#]]=v;
DFS[#]])&,e[[v]] ])

Mb[g_Graph,start_Integer]:=
Block[{bejarva={},e=ToAdjacencyLists[g],elek={},szulo=Table[0,{V[g]}]},
szulo[[start]]=start;
DFS[start];
{ bejarva,Table[szulo[[bejarva[[i]] ]],{i,1,V[g]}] }]

Mb[OrientGraph[Wheel[10]],1]

Mb[PetersenGraph,3]

CsucslistaM[g_Graph,cs_Integer]:=Module[{m2=Table[Mb[g,cs][[1]][[1;;i]],{i,1,V[g]}]},Table[AppendTo[m2[[j]],{VertexColor->Purple}],{j,1,V[g]}]];
EllistaM[g_Graph,cs_Integer]:=Module[{n2=Table[Table[{Mb[g,cs][[2]][[i]],Mb[g,cs][[1]][[i]]},{i,1,V[g]}][[1;;j]],{j,1,V[g]}]},Table[AppendTo[n2[[j]],{EdgeColor->Blue,EdgeStyle->Thick}],{j,1,V[g]}]];
Melysegi[g_Graph,cs_Integer]:=Module[{m=CsucslistaM[g,cs],n=EllistaM[g,cs]},Manipulate[ShowGraph[g,List[m[[a]],n[[a]]],VertexNumber->On],{{a,1,"Lépésszám"},1,V[g],1}]]

Melysegi[PetersenGraph,5]

Irányított gráfra mélységi bejárás:

Melysegi[OrientGraph[Wheel[10]],1]

Melysegi[DeBruijnGraph[2,3],2]

Mélységi és szélességi bejárás

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

Mindkét bejárási móddal különböző gráfok bejárása:

Bejaras[g_Graph, csucs_Integer]:=TableForm[{{Szelessegi[g,csucs],Melysegi[g,csucs]}}]

Bejaras[PetersenGraph,3]

Bejaras[ButterflyGraph[2],10]

Bejaras[GeneralizedPetersenGraph[10,5],3]

Bejaras[DeBruijnGraph[2,4],4]

Bejaras[OrientGraph[CompleteGraph[10]],2]

Bejaras[CompleteGraph[10],2]

Dinamikus programozás

A dinamikus programozás lényege abban rejlik, hogy a problémák megoldását részfeladatok megoldásaiból állítjuk elő.
A részeredményeket táblázatban tároljuk, aminek kitöltését általában valamilyen rekurzív összefüggés teszi lehetővé.

Nagyságrendek

Definíció: f,g: ℕ→ℝ
f(n)=O(g(n)) (f nagy ordó g), 		ha ∃c>0, (Subscript[n, 0])∈ℕ	∀n≥ (Subscript[n, 0]) esetén |f(n)| ≤ c|g(n)|.
f(n)=Ω(g(n)) (f nagy omega g), 	ha ∃c>0, (Subscript[n, 0])∈ℕ	∀n≥ (Subscript[n, 0]) esetén |f(n)| ≥ c|g(n)|.
f(n)=Θ(g(n)) (f nagy teta g), 		ha f(n)=O(g(n)) és f(n)=Ω(g(n)), azaz	∃(Subscript[c, 1]),(Subscript[c, 2])>0, (Subscript[n, 0])∈ℕ  ∀n≥ (Subscript[n, 0]) esetén (Subscript[c, 1])|g(n)| ≤ |f(n)| ≤ (Subscript[c, 2])|g(n)||.

Első példa: Binomiális együtthatók számítása dinamikus programozással

(({{n}, {k}})) = (({{n-1}, {k}})) + (({{n-1}, {k-1}})) azonosságot használva kaphatjuk meg a keresett értéket.
Ha az összes (({{n-1}, {j}})) értéket ismerjük (0≤ j≤ n-1), akkor az (({{n}, {k}})) alakú együtthatók egy-egy összeadással kaphatók meg. Az (({{m}, {0}}))=(({{m}, {m}}))=1 értékekből indulunk ki. Tulajdonképpen a Pascal-háromszög kitöltéséről van szó.
Ez a módszer jobb, mint rekurzív eljárással, mert rekurzió esetén egy binomiális együtthatót többször kiszámolunk:
									           (({{n}, {k}})) 
										          (({{n-1}, {k}}))                                   +                              (({{n-1}, {k-1}}))
									   (({{n-2}, {k}}))        +        (({{n-2}, {k-1}}))                               (({{n-2}, {k-1}}))        +        (({{n-2}, {k-2}}))
							        (({{n-3}, {k}}))+(({{n-3}, {k-1}}))   (({{n-3}, {k-1}}))+(({{n-3}, {k-2}}))      (({{n-3}, {k-1}}))+(({{n-3}, {k-2}}))   (({{n-3}, {k-2}}))+(({{n-3}, {k-3}}))
Gyakorlati szempontból olyan környezetben érdekes, ahol az összeadás sokkal gyorsabb mint a szorzás.

binomial[n_Integer,k_Integer]:=
Module[
{L=Table[Table[0,{n+1}],{n+1}]},
Table[L[[l]][[1]]=1,{l,1,n+1}];                          (*kezdőértékek beállítása*)
Table[L[[l]][[l]]=1,{l,1,n+1}];
Table[Table[L[[i]][[j]]=L[[i-1]][[j]]+L[[i-1]][[j-1]],{j,2,i}],{i,3,n+1}]; L[[n+1]][[k+1]]]    (*a keresett elem a lista L[n+1][k+1]-edik eleme*)

binomial[10,2]

A táblázat kitöltésének lépései, példák:

binomial2[n_Integer,k_Integer]:=
Module[
{L=Table[Table[0,{n+1}],{n+1}]},
Table[L[[l]][[1]]=1,{l,1,n+1}];
Table[L[[l]][[l]]=1,{l,1,n+1}];
Table[Table[L[[i]][[j]]=L[[i-1]][[j]]+L[[i-1]][[j-1]],{j,2,i}],{i,3,n+1}];
L[[n+1]][[k+1]]=Framed[L[[n+1]][[k+1]]];        (*a keresett elem bekeretezése a táblázatban*)
TableForm[L]]

binomial2[10,2]

binomial2[6,5]

binomial2[3,2]

binomial2[17,5]

Az eljárás költsége: 1+2+3+...+n=((n(n+1))/2) binomiális együtthatóra van szükség, tehát az algoritmus O((n^2))-es.

A Mathematica Binomial parancsa ebben a környezetben jóval gyorsabb, mint ez az eljárás.

Binomial[200,24]//AbsoluteTiming

binomial1[n_,k_]:=n!/(k!*(n-k)!)

binomial1[200,24] //AbsoluteTiming

binomial[200,24] //AbsoluteTiming

Második példa: Hátizsák probléma

A probléma megfogalmazása:
Adott n darab tárgy, (Subscript[s, 1]), (Subscript[s, 2]), ... , (Subscript[s, n]) súlyokkal, (Subscript[v, 1]), (Subscript[v, 2]), ... , (Subscript[v, n])  értékekkel, valamint egy hátizsák b súlykorláttal.
A kérdés a maximális érték, ami a súlykorlát és a súlyok figyelembe vételével elérhető.

A részértékek a táblázatban: T[i,a] = maximális bepakolható érték az első i tárgyból, a súlykorláttal.
T[1,a] = 0,  ha (Subscript[s, 1])>a, és T[1,a] = (Subscript[v, 1]),  ha (Subscript[s, 1])≤a.
T[i,a]=T[i-1,a], ha (Subscript[s, i])>a, és T[i,a]=max{T[i-1,a-(Subscript[s, i])]+(Subscript[v, i]); T[i-1,a]}, ha (Subscript[s, i])≤a.

A táblázat kitöltése n b lépésben történik, tehát az algoritmus költsége O(n b).
A bemenet: b,(Subscript[s, 1]), (Subscript[s, 2]), ... , (Subscript[s, n]), (Subscript[v, 1]), (Subscript[v, 2]), ... , (Subscript[v, n]) , hossza: ⌈log(b+1)⌉+⌈log((Subscript[s, 1])+1)⌉+...+⌈log((Subscript[s, n])+1)⌉+⌈log((Subscript[v, 1])+1)⌉+...+⌈log((Subscript[v, n])+1)⌉.
A lépésszám exponenciális b-ben, tehát ez az algoritmus akkor jó, ha a  b nem túl nagy.

hatizsak[suly_List,ertek_List,krl_Integer]:=
Module[
{T=Table[Table[0,{krl}],{Count[suly,_Integer]}]},         (*Count[suly,_Integer]=Length[suly]=a súlyok listájának hossza*)
Table[If[suly[[1]]>a,T[[1]][[a]]=0,T[[1]][[a]]=ertek[[1]]],{a,1,krl}];   (*első sor kitöltése*)
Table[Table[If[suly[[i]]>a,T[[i]][[a]]=T[[i-1]][[a]],T[[i]][[a]]=Max[T[[i-1]][[a]],ertek[[i]]+If[a-suly[[i]]<=0,0,T[[i-1]][[a-suly[[i]]] ]] ]],{a,1,krl}],{i,2,Count[suly,_Integer]}];
 T[[Count[suly,_Integer]]][[krl]]]

hatizsak2[suly_List,ertek_List,krl_Integer]:=
Module[
{T=Table[Table[0,{krl}],{Count[suly,_Integer]}]},
Table[If[suly[[1]]>a,T[[1]][[a]]=0,T[[1]][[a]]=ertek[[1]]],{a,1,krl}];
Table[Table[If[suly[[i]]>a,T[[i]][[a]]=T[[i-1]][[a]],T[[i]][[a]]=Max[T[[i-1]][[a]],ertek[[i]]+If[a-suly[[i]]<=0,0,T[[i-1]][[a-suly[[i]]] ]] ]],{a,1,krl}],{i,2,Count[suly,_Integer]}];
T[[Count[suly,_Integer]]][[krl]]=Framed[T[[Count[suly,_Integer]]][[krl]]]; TableForm[T]]

sulyok={7,5,4,1};
ertekek={20,14,10,1};
korl=10;
hatizsak2[sulyok,ertekek,korl]

sulyok2={7,5,3,2,6,3,8};
ertekek2={5,16,4,8,12,10,20};
korl2=15;
hatizsak[sulyok2,ertekek2,korl2]

hatizsak2[sulyok2,ertekek2,korl2]

Harmadik példa feladat

Adott egy n x n-es Boole-tömb (elemei 0 és 1).
Kell: legnagyobb csupa 1-esből álló négyzet.

Megoldás:
B n x n-es tömb, melyre B[i,j] = k pontosan akkor, ha az A táblázat legnagyobb csupa 1-es négyzete, aminek a jobb alsó sarka A[i,j] éppen k x k-as méretű.

Eredeti (A) tömb generálása:

tombgen[n_]:=RandomInteger[1,{n,n}]

A=tombgen[20];
A//TableForm

B tömb kiszámítása:
B[1, j]=A[1, j],
B[i, 1]=A[i, 1],
Ha A[i, j]=1, akkor ha {B[i-1, j], B[i, j-1], B[i-1, j-1]} elemei mind ≥1, akkor B[i, j]=B[i-1, j-1]+1, egyébként B[i, j]=1.

ujtomb[A_List,n_Integer]:=
Module[
{i,j,B=Table[Table[0,{n}],{n}]},
Table[B[[1]][[j]]=A[[1]][[j]],{j,1,n}];
Table[B[[i]][[1]]=A[[i]][[1]],{i,1,n}];
Table[Table[If[A[[i]][[j]]== 1,If[A[[i]][[j-1]]≥1&&A[[i-1]][[j]]≥1&&A[[i-1]][[j-1]]≥1,B[[i]][[j]]=B[[i-1]][[j-1]]+1,B[[i]][[j]]=1],B[[i]][[j]]=0],{j,2,n}],{i,2,n}];
B]

ujtomb[A,20]//TableForm

valasz[A_List,n_Integer]:=Max[Flatten[ujtomb[A,n]]]

valasz[A,20]

Időigény: O((n^2))
B-nek (n^2) eleme van, tehát a táblázat kitöltéséhez (n^2) lépés szükséges. Ezután minden elemet három másikból számolunk ki, tehát minden új elemre konstans munka jut.

Negyedik példa feladat

Adott egy (Subscript[s, 1])(Subscript[s, 2])... (Subscript[s, n])  szó.
Hány a-val kezdődő és b-re végződő részszava van s-nek?

a="sfeesfuzefsdghsgefíasysdjfhvyhndbvababababababbbbaahgefeszf"

A=Characters[a]

B[i]= a betűk száma (Subscript[s, 1])(Subscript[s, 2])... (Subscript[s, i])-ben. B megvan az s egy végigolvasásával: O(n) lépésben.

tomb1[a_]:=Module[{i,A=Characters[a],B=Table[0,{Length[A]}]},
If[A[[1]]=="a",B[[1]]=1,B[[1]]=0];
Table[If[A[[i]]=="a",B[[i]]=B[[i-1]]+1,B[[i]]=B[[i-1]]],{i,2,Length[A]}];B]

tomb1[a]

Utána minden b előfordulásra megnézzük B-ből, hogy hány a volt előtte. Ezeket összeadom: O(n).

tomb2[a_]:=Module[{sum=0,i,A=Characters[a],b=tomb1[a]},Table[If[A[[i]]=="b",sum=sum+b[[i]]],{i,1,Length[A]}];sum]

tomb2[a]

Beépített paranccsal (StringCount, StringCases, RegularExpression):

StringCount["sfeesfuzefsdghsgefíasysdjfhvyhndbvababababababbbbaahgefeszf",RegularExpression["a.*b"], Overlaps->All]

StringCases["sfeesfuzefsdghsgefíasysdjfhvyhndbvababababababbbbaahgefeszf",RegularExpression["a.*b"], Overlaps->All]

tomb2[a]//AbsoluteTiming

StringCount[a,RegularExpression["a.*b"], Overlaps->All] //AbsoluteTiming

Gráfalgoritmus dinamikus programozással

Bellman-Ford algoritmus

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

Adott egy G=(V,E) gráf c: E→ℝ, melyben nincs negatív kör.
Feladat: az 1-es csúcsból az összes többibe vezető legrövidebb utak hossza.

T[i, k] = 1-ből i-be menő legfeljebb k élű utak minimális hossza.
A válasz: a táblázat utolsó oszlopa.

T[i, 1]	= 0, 		ha i = 1
	= c(1, i), 	ha (1, i) ∈ E
	= ∞		ha (1, i) ∉ E

T[i, k] = min{ (min_j){T[j, k-1]+c(j, i)}, T[i, k-1]}
Állítás: ez jó, valóban a minimális út hosszát határozza meg.
Lépésszám: 1 elem kitöltésére fordított költség: O(n), n(n-1) a táblázat mérete, minimum meghatározása: (n - 1) összehasonlítással, tehát összesen O((n^3))

g=PetersenGraph;
l=Sort[Edges[g]];
g=SetEdgeWeights[g,Edges[g],{-1,2,-3,4,5,6,7,-8,9,10,11,12,13,14,15}];
c=GetEdgeWeights[g];

suly[el_List,ellist_List,c_List]:=Module[{j},For[j=1,j≤Length[ellist],j++,If[el==ellist[[j]],Return[c[[j]]]]]]

suly2[el_List,ellist_List,c_List]:=Module[{},If[MemberQ[ellist,el],suly[el,ellist,c],If[MemberQ[ellist,{el[[2]],el[[1]]}],suly[{el[[2]],el[[1]]},ellist,c]]]]

BellmanFordalg[g_Graph]:=Module[{i,k,csucslist=VertexList[g],ellist=Sort[Edges[g]], T=Table[Table[0,{V[g]-1}],{V[g]}],c=GetEdgeWeights[g]},
Table[If[i==1,T[[i]][[1]]=0,If[MemberQ[ellist,{1,i}],T[[i]][[1]]=suly2[{1,i},ellist,c],T[[i]][[1]]=∞]],{i,1,V[g]}];
Table[Table[T[[i]][[k]]=Min[Min[Table[If[MemberQ[ellist,{j,i}],T[[j]][[k-1]]+suly2[{j,i},ellist,c],∞],{j,1,V[g]}]],T[[i]][[k-1]]],{k,2,V[g]-1}],{i,1,V[g]}];
TableForm[T,TableHeadings->{Table[i,{i,1,V[g]}],Table[j,{j,1,V[g]-1}]}]]

BellmanFordalg[g]

ShowGraph[g,EdgeLabel->Table[suly[Edges[g][[i]],Sort[Edges[g]],GetEdgeWeights[g]],{i,1,Length[Edges[g]]}], VertexNumber->On,EdgeLabelColor->Green]

g1=Wheel[7];
l1=Sort[Edges[g1]];
g1=SetEdgeWeights[g1,Edges[g1],{1,2,3,-4,5,6,7,8,9,10,11,12}];
c1=GetEdgeWeights[g1];

BellmanFordalg[g1]

ShowGraph[g1,EdgeLabel->Table[suly[Edges[g1][[i]],Sort[Edges[g1]],GetEdgeWeights[g1]],{i,1,Length[Edges[g1]]}], VertexNumber->On,EdgeLabelColor->Green]

g2=GeneralizedPetersenGraph[7,3]

BellmanFordalg[g2]

ShowGraph[g2,EdgeLabel->Table[suly[Edges[g2][[i]],Sort[Edges[g2]],GetEdgeWeights[g2]],{i,1,Length[Edges[g1]]}], VertexNumber->On,EdgeLabelColor->Green]

ShortestPath beépített függvény - magát a legrövidebb utat határozza meg

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

Lista[z_List]:=Module[{z2=Table[Table[{z[[i]],z[[i+1]]},{i,1,Length[z]-1}][[1;;i]],{i,1,Length[z]-1} ]},Table[AppendTo[z2[[j]],{EdgeColor->Purple,EdgeStyle->Thick}],{j,1,Length[z]-1}]];
Lista2[z_List]:=Module[{z1=Table[z[[1;;i]],{i,1,Length[z]}]},Table[AppendTo[z1[[j]],{(*VertexStyle->Disk[Large],*)VertexColor->Blue}],{j,2,Length[z]}]];
LegRovUt[g_,kezd_Integer, veg_Integer]:=Module[{list=ShortestPath[g,kezd,veg],m=Lista[ShortestPath[g,kezd,veg]], n=Lista2[ShortestPath[g,kezd,veg]]},
Manipulate[ShowGraph[g,List[m[[a]],n[[a]]],VertexNumber->On],{a,1,Length[list]-1,1}]]

LegRovUt[ButterflyGraph[2],1,10]

LegRovUt[ButterflyGraph[3],1,24]

Adatszerkezetek

Általában egy adatszerkezetnél meg kell adni a műveleteket, ezeket meg kell valósítani, és azt is meg kell mondanunk, hogy milyen típusú adatokat tárolunk.
Ha tudjuk, mit szeretnénk, akkor tudni kell megvalósítani azt az adatszerkezetet.

Teljes bináris fa

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

Teljes bináris fa: minden nem levél csúcsnak két fia van, az utolsó szinten hiányozhatnak csúcsok, vagyis a levelek az utolsó két szinten lehetnek.
Ha n csúcsot szeretnénk a fában tárolni, akkor a fának körülbelül (Subscript[log, 2])n a szint nagysága.

A teljes bináris fát egy tömbben tárolhatjuk, ekkor teljesül, hogy a tömb i -edik elemének két fia: A[2i] és A[2i+1], az apja pedig A[⌊(i/2)⌋].
A teljesség miatt minden tömbelemnek megfelel egy csúcs.

h={21,19,9,17,5,8,6,4,11,13}

listing[h_List]:=Module[{l={}, n=Length[h]},For[i=1,i<n,i++,
If[2i≤n,AppendTo[l,{i,2i}]];
If[2i+1≤n,AppendTo[l,{i,2i+1}]]
];l];
TeljesBin[h_List]:=Module[{},ShowGraph[RootedEmbedding[AddEdges[EmptyGraph[Length[h]],listing[h]]], VertexLabel->h, VertexStyle->Disk[0.1], VertexColor->Lighter[Blue], VertexLabelPosition->Center]]

TeljesBin[h]

h2=RandomInteger[1000,13]

TeljesBin[h2]

Kupac

Needs["Combinatorica`"];
Needs["GraphUtilities`"];

A kupac műveletei: BESZÚR, MINTÖR, KUPACÉPÍTÉS.
A kupac egy teljes bináris fa, melynek csúcsaiban tároljuk az elemeket.
Erre a teljes bináris fára teljesül a kupactulajdonság, vagyis minden v csúcsra teljesüljön, hogy a v-beli elem kisebb mint a v fiaiban lévő elemek.

Tehát a kupacban a legkisebb elem a gyökérben van.

h={21,19,9,17,5,8,6,4,11,13}

HeapQ függvény: ellenőrzi a kupactulajdonságot egy tömbre.

HeapQ[a_List]:=Module[{i,n=Length[a]},And@@Table[a[[Floor[i/2]]]<a[[i]],{i,2,n}]]

HeapQ[h]

KUPACOL (segédművelet):
A bemenet egy teljes bináris fa, melynek a jobb és bal részfája kupac.
Kimenete egy kupac.
(Subscript[a, i]):=min((Subscript[a, b]),(Subscript[a, j]))
Ha x<(Subscript[a, i]), akkor a fa jó.
Ha x>(Subscript[a, i]), akkor kicseréljük a két elemet.
Meghívjuk a KUPACOL eljárást a részfára, amit változtattunk.

Az eljárás végén a fa valóban kupac lesz.
Lépésszáma O(log n) összesen.

KUPACÉPÍTÉS (beépített függvény: Heapify) művelet működése:
Teljes bináris fában lentről fel, jobbról balra haladva minden csúcsra meghívjuk a KUPACOL műveletet.
Ennek eredménye egy kupac, lépésszáma O(n), ahol n a csúcsok száma.

h={21,19,9,17,5,8,6,4,11,13}

Heapify[h]

listing[h_List]:=Module[{l={}, n=Length[h]},For[i=1,i<n,i++,
If[2i≤n,AppendTo[l,{i,2i}]];
If[2i+1≤n,AppendTo[l,{i,2i+1}]]
];l];
Kupac[h_List]:=Module[{},ShowGraph[RootedEmbedding[AddEdges[EmptyGraph[Length[Heapify[h]]],listing[Heapify[h]]]], VertexLabel->Heapify[h], VertexStyle->Disk[0.1], VertexColor->Lighter[Green], VertexLabelPosition->Center]]

Kupac[h]

h

HeapQ[h]

h=Heapify[h]

HeapQ[h]

h2=RandomInteger[100,16]

Kupac[h2]

BESZÚR művelet: Új elem beillesztése. 
Az új elemet a teljes bináris fa első hiányzó csúcsába tesszük.
Ha az új elem kisebb, mint az apja, akkor megcseréljük vele. Ezt folytatjuk, amíg egy lépésben az új elem nagyobb lesz mint az apja vagy a gyökérbe kerül.
A kapott bináris fa egy kupac.
A művelet lépésszáma O(log n).

h={21,19,9,17,5,8,6,4,11,13}

h=Heapify[h]

Beszur[h_List,v_Integer]:=Module[{l={},i=Length[h]+1,tmp=Heapify[h],j},
If[HeapQ[h]≠True,l=Heapify[h],l=h];
AppendTo[l,v];
For[j=i,j≥1,j=Floor[j/2],If[l[[ Floor[j/2] ]]>l[[j]],(l[[Floor[j/2] ]]=l[[j]];l[[j]]=tmp[[Floor[j/2]]]),Break]];
l
]

h=Beszur[h,2]

Kupac[h]

MINTÖR művelet:
A legkisebb elemet kiszedjük a gyökérből. Ezután a fa utolsó levelét töröljük, a gyökér helyére tesszük ezt az elemet.
Az eredményül kapott fával meghívjuk a KUPACOL eljárást. Így egy kupacot kapunk, O(log n) lépésben.

h={21,19,9,17,5,8,6,4,11,13}

Mintor[h_List]:=Module[{l=h},
If[! HeapQ[l],Heapify[l]];
l=Drop[l,1];
l
]

h=Mintor[h]

Kupac[h]

h=Mintor[h]

Kupac[h]

Kupacrendezés

k:=RandomInteger[{1,10000},100]

HeapSort[k]//AbsoluteTiming

Sort[k] //AbsoluteTiming

Források, hivatkozások

Rónyai Lajos, Ivanyos Gábor, Szabó Réka: Algoritmusok
Typotex kiadó, 2008

Sriram Pemmaraju, Steven Skiena: Computional Discrete Mathematics
Cambridge University Press, 2003