Véletlen partíciók generálása

Programozási Feladat 3

A kínai étterem folyamat

A következő program a kínai étterem folyamatot reprezentálja. A beérkezők számát megadva az egyes asztaloknál ülő emberek számát kapjuk eredményül.

kinai[hanyan_]:= Module[{},lista={1};
Table[m=RandomChoice[Append[lista,1] -> Range[Length[lista]+1]];
If[ m>Length[lista], AppendTo[lista,1],  lista[[m]]= lista[[m]]+1 ],{hanyan-1}];lista]

kinai[100]

kinai[100]

Ennek megjelenítésére az alábbi program használható:

Graphics[{Array[Circle[{3*(#-1),0}, 0.7]&,Length[lista]],
Flatten[Table[Array[Circle[{(3*(q-1))-Cos[10*#1*Pi/200],Sin[10*#1*Pi/200]}, 0.05]&,lista[[q]]],{q,Length[lista]}]]}]

Adott listához megjeleníthető az érkezési sorrend:

kinaiuj[hanyan_] := Module[{}, lista = {1};
  Table[m = RandomChoice[Append[lista, 1] -> Range[Length[lista] + 1]];
   If[ m > Length[lista], AppendTo[lista, 1],  lista[[m]] = lista[[m]] + 1 ];lista, {hanyan - 1}]]

listauj=kinaiuj[100]

Manipulate[Graphics[{Array[Circle[{3*(#-1),0}, 0.7]&,Length[listauj[[i]]]],
Flatten[Table[Array[Circle[{(3*(q-1))-Cos[10*#1*Pi/200],Sin[10*#1*Pi/200]}, 0.05]&,listauj[[i]][[q]]],{q,Length[listauj[[i]]]}]]}],{i,1,99,1}]

A ciklusokat rendezhetjük nagyság szerinti sorrendbe is:

Sort[lista,Greater]

A (Subscript[K, n]) jelöli az n érkező után elfoglalt asztalok számát. Erre a következő teljesül: ((Subscript[K, n])/logn)->1, ha n->∞:

A következő ábrán látható, hogy a ciklusok száma logn-hez tart. Itt egy adott számra többször is kiszámoljuk az értéket.

ListPlot[Map[Length,Flatten[Table[kinai[x],{x,1,2000,20},{10}],1]]]

Plot[Log[x],{x,1,2000}]

A következő több próbára számolja ki a ciklusok számának átlagát:

Map[Length,Flatten[Table[kinai[x],{x,1,20},{10}],1]]

t={}
Array[AppendTo[t,(Sum[Map[Length,Flatten[Table[kinai[x],{x,1,20},{10}],1]][[i]],{i,(#-1)*10+1,#*10}])/10]&,{20}];t

ListLinePlot[t]

Ez összevonva egy programba:

atlag[hanyan_,hanyproba_]:= Module[{}, t={};
Array[AppendTo[t,(Sum[Map[Length,Flatten[Table[kinai[x],{x,1,hanyan},{hanyproba}],1]][[i]],{i,(#-1)*10+1,#*10}])/hanyproba]&,{hanyan}];Print[t];ListPlot[{t,Table[Log[x],{x,1,hanyan}]}]
]

atlag[20,10]

Plot[Log[x],{x,1,20}]

Ha többször is elvégezzük a próbát adott számú vendégek esetén, akkor a ciklusok hosszát ábrázolhatjuk:

abra[hanyember_,hanyproba_]:=Module[{e=hanyember, p= hanyproba},ListPlot[Table[Table[Length[kinai[r]],{p}],{r,e}]]]

abra[10,100]

Manipulate[abra[x,y],{x,1,100},{y,1,100}]

ListPlot[Table[Length[kinai[x]],{x,1,200}]]

ListPlot[Table[(Length[kinai[x]])/(Log[x]),{x,2,200}]]

A ciklusok hosszát a következőképp is vizsgálhatjuk:

ciklus[hanyan_,hanyszor_]:=Module[{},listauj=Sort[Flatten[Table[kinai[hanyan],{hanyszor}],1],Greater];Print[listauj];
k={};
Table[
If[
MemberQ[listauj,i],AppendTo[k,{i,Count[listauj,i]}],Cases[Range[hanyan],Except[i]]
],{i,1,hanyan}];k]

ciklus[1000,10]

ListPlot[k]

Véletlen ültetési rend parciálisan felcserélhető partícióhoz. Adott (Subscript[P, i]) valószínűségekhez generálunk ülésrendet. A (Subscript[P, i]) valószínűségeknek teljesíteiük kell a következőket: 0 ≤ (Subscript[P, i]) ∀i-re, illetve (∑_(i=1)^k)(Subscript[P, i]) < 1. Afeltételeknek megfelelő valószínűségeket generálunk (a lényeg az, hogy bármely ilyen adott valószínűségekre működik).

val=Table[RandomReal[],{100}];
val2=Map[#/(Sum[val[[i]],{i,Length[val]}]+1)&,val]

Ehhez pedig a következő módon adhatjuk meg az ülésrendet:

adottsulyokhoz[hanyan_]:= Module[{},lista={1};
Table[m = RandomChoice[ Append[val2[[1;;Length[lista]]],1-(Sum[val2[[p]],{p,Length[lista]}])]-> Range[Length[lista] + 1]];
If[ m>Length[lista], AppendTo[lista,1],  lista[[m]]= lista[[m]]+1 ],{hanyan-1}];lista]

adottsulyokhoz[96]

Graphics[{Array[Circle[{3*(#-1),0}, 0.7]&,Length[lista]],
Flatten[Table[Array[Circle[{(3*(q-1))-Cos[10*#1*Pi/200],Sin[10*#1*Pi/200]}, 0.05]&,lista[[q]]],{q,Length[lista]}]]}]

A kétparaméteres modell

A kétparaméteres modell esetén az előző modellt módosítjuk. Az új érkezők az (α,θ) értékek függvénye alapján megválasztott valószínűséggel foglal helyet.

ketparameteres[alfa_,theta_,hanyan_]:= Module[{a=alfa,t=theta,h = hanyan} ,lista={1};
Table[m=RandomChoice[lista2=Append[lista,(t + a*(Length[lista]+1))];
Function[x,(x-a)/(Sum[lista[[i]],{i,1,Length[lista]}]+ t)] /@lista2 -> Range[Length[lista]+1]];
If[ m>Length[lista], AppendTo[lista,1],  lista[[m]]= lista[[m]]+1 ],{h-1}];lista]

ketparameteres[0,8,100]

Az így kapott listát szintén ábrázolhatjuk:

Graphics[{Array[Circle[{10*(#-1),0}, 2]&,Length[lista]],Array[Inset[(((Subscript[n, #])-α)/(n+ θ)),{10*(#-1),0}]&,Length[lista]-1],Inset[((θ+ kα)/(n+θ)),{10*(Length[lista]-1),0}],
Flatten[Table[Array[Circle[{(10*(q-1))-3*Cos[10*#1*Pi/200],3*Sin[10*#1*Pi/200]}, 0.05]&,lista[[q]]],{q,Length[lista]}]]}]

Ekkor az α és θ paraméterek függvényében a következőket figyelhetjük meg:
Ha α < 0, akkor (Subscript[K, n]) θlogn szerint növekszik.

ListPlot[{Table[Length[ketparameteres[-0.001,2,x]],{x,1,1000,20}],Table[2*Log[x],{x,1,1000,20}]}]

RandomPartition