Diskrétní matematika

Antonín Slavík
MFF UK

Permutace, variace, kombinace

Permutace

Permutace bez opakování:

Permutations[{a,b,c,d}]

Permutace s opakováním:

Permutations[{a,a,b,c,c}]

Jejich počet:

?Multinomial

Multinomial[2,1,2]

Variace

Variace bez opakování:

Permutations[{a,b,c,d,e},{3}]

Jejich počet:

FactorialPower[n,k] vrací n(n-1)⋯(n-k+1).

FactorialPower[5,3]

Obecněji, pro x∈ℝ a n∈ℕ zavedeme označení (x^(UnderBar[k]))=x(x-1)⋯(x-k+1), a dále dodefinujeme (x^(UnderBar[0]))=1. Těmto číslům se říká klesající (sestupné) mocniny.

Variace s opakováním:

Tuples[{a,b,c,d},3]

Kartézský součin:

Tuples[{{a,b,c},{1,2,3}}]

Kombinace

Kombinace bez opakování:

Subsets[{a,b,c,d,e},{3}]

Jejich počet:

Binomial[5,3]

Pascalův trojúhelník:

TableForm[Table[Binomial[n,k],{n,0,10},{k,0,n}]]

Všechny podmnožiny:

Subsets[{a,b,c,d}]

Kombinace s opakováním:

Union[Map[Sort,Tuples[{a,b,c,d,e},3]]]

Stirlingova a Bellova čísla

Stirlingova čísla druhého druhu

Kolika způsoby lze rozdělit n lidí do k skupin? (V každé skupině musí být aspoň jedna osoba.)

Myšlenka: Každé rozdělení n lidí do k skupin vznikne z rozdělení n-1 lidí do k-1 skupin (n-tá osoba bude sama v k-té skupině), nebo z rozdělení n-1 lidí do k skupin (n-tou osobu zařadíme do některé z existujících skupin).

vlozDoSkupin[s_,x_]:=Table[ReplacePart[s,i->Append[s[[i]],x]],{i,1,Length[s]}]

vlozDoSkupin[{{1,2},{3}},x]

skupiny[n_,1]:={{Range[n]}}
skupiny[n_,k_]:={}/;k>n
skupiny[n_,k_]:=
Join[Map[Append[#,{n}]&,skupiny[n-1,k-1]],
Join@@Map[vlozDoSkupin[#,n]&,skupiny[n-1,k]]]

skupiny[3,2]

skupiny[5,3]

Grid[%]

Length[%%]

StirlingS2[5,3]

Stirlingův trojúhelník druhého druhu:

TableForm[Table[StirlingS2[n,k],{n,1,10},{k,1,n}]]

Stirlingova čísla prvního druhu

Každou permutaci lze rozložit na cykly. Např. permutace {2,4,3,1,6,8,5,7} vypadá takto:

GraphPlot[{1->2,2->4,3->3,4->1,5->6,6->8,7->5,8->7},DirectedEdges->True,BaseStyle->14,VertexLabeling->True,ImageSize->Small,PlotStyle->Arrowheads[{{Medium,0.6}}]]

Tento rozklad zapíšeme ve tvaru {{1,2,4},{3},{5,6,8,7}}.

Kolik existuje permutací množiny {1, …, n}, které jsou složeny z k cyklů?

Myšlenka: Každá permutace n čísel s k cykly vznikne buď z permutace n-1 čísel s k-1 cykly (n-té číslo bude tvořit k-tý cyklus), nebo z permutace n-1 čísel s k cykly (n-té číslo zařadíme do některého z existujících cyklů).

(* Vloží x postupně na všechny možné pozice v cyklu c *)
vlozDoCyklu[c_,x_]:=Table[Insert[c,x,i],{i,1,Length[c]}]

vlozDoCyklu[{1,2},x]

(* Vloží x postupně do všech cyklů v permutaci p *)
vlozDoPermutace[p_,x_]:=Join@@Table[Map[ReplacePart[p,i->#]&,vlozDoCyklu[p[[i]],x]],{i,1,Length[p]}]

vlozDoPermutace[{{1,2},{3}},x]

permutace[n_,0]:={}
permutace[n_,k_]:={}/;k>n
permutace[1,1]:={{{1}}}
permutace[n_,k_]:=Join[Map[Append[#,{n}]&,permutace[n-1,k-1]],
Join@@Map[vlozDoPermutace[#,n]&,permutace[n-1,k]]]

permutace[3,2]//Grid

permutace[5,3]

Grid[%]

Length[%%]

StirlingS1[n,k] vrací (((-1))^(n-k)) krát počet permutací n čísel s k cykly.

StirlingS1[5,3]

Poznámka: Definice Stirlingových čísel prvního druhu jsou nejednotné, faktor (((-1))^(n-k)) se někdy vynechává.

Stirlingův trojúhelník prvního druhu:

TableForm[Table[Abs[StirlingS1[n,k]],{n,1,10},{k,1,n}]]

Další použití Stirlingových čísel

(x^0), (x^1), …, (x^n) tvoří bázi prostoru všech polynomů stupně nejvýše n.

(x^(UnderBar[0])), (x^(UnderBar[1])), …, (x^(UnderBar[n])) je rovněž bází tohoto prostoru.

Matice přechodu mezi těmito bázemi jsou tvořeny Stirlingovými čísly:

({{({{(x^(UnderBar[k]))=(∑_(m=0)^k)StirlingS1[k,m](x^m)}}),}})

({{({{(x^k)=(∑_(m=0)^k)StirlingS2[k,m](x^(UnderBar[m]))}}).}})

Příklad:

FunctionExpand[FactorialPower[x,7]]

Expand[%]

Table[StirlingS1[7,m],{m,0,7}]

Bellova čísla

Kolika způsoby lze n lidí rozdělit do neprázdných skupin?

skupiny2[n_]:=Join@@Table[skupiny[n,k],{k,1,n}]

skupiny2[4]

Grid[%]

Length[%%]

BellB[n] vrací počet rozdělení n lidí do neprázdných skupin. (Ekvivalentně: počet rozkladů n-prvkové množiny na podmnožiny).

Grid[Transpose[Table[{Style[n,FontWeight->Bold],BellB[n]},{n,1,12}]],Dividers->All,BaseStyle->{FontFamily->"Arial",FontSize->20}]

Další speciální funkce

Fibonacciova čísla (Fibonacci), Catalanova čísla (CatalanNumber), Eulerova čísla (EulerE), Bernoulliova čísla (BernoulliB), …

Posloupnosti, diskrétní kalkulus

Posloupnosti

Řešení rekurentních rovnic:

RSolve[a[n]==2a[n-1]+1,a[n],n]

RSolve[{a[n]==2a[n-1]+1,a[1]==1},a[n],n]

RSolve[{a[n]==a[n-1]+a[n-2],a[1]==1,a[2]==1},a[n],n]

FunctionExpand[Fibonacci[n]]

Uhodnutí vzorce na základě počátečních členů:

FindSequenceFunction[{1,4,9,16,25},n]

FindSequenceFunction[{2,4,7,11,16},n]

FindSequenceFunction[{1,1,2,3,5,8},n]

Další pokusy:

FindSequenceFunction[{1,2,3,5,6,7},n]

FindSequenceFunction[{1,2,3,5,6,7,9,10,11},n]

FindSequenceFunction[{1,1,3,1,3,5,7,1,3,5,7,9},n]

Diskrétní kalkulus

Diskrétní kalkulus je analogií klasického spojitého kalkulu, místo funkcí pracuje s posloupnostmi. Základní dvě operace jsou diference a antidiference (neurčitá suma).

Diference: Δ(Subscript[a, n])=(Subscript[a, n+1])-(Subscript[a, n])

DifferenceDelta[a[n],n]

Ekvivalentní zápis (EscdiffdEsc):

(Subscript[∆, n])a[n]

Diference vyšších řádů:

Map[Reverse,Table[DifferenceDelta[a[n],{n,k}],{k,1,8}]]//TableForm

DifferenceDelta[n,n]

DifferenceDelta[n^2,n]

DifferenceDelta[n^3,n]

Analogií klasického vzorce (d/(dx))((x^a))=a·(x^(a-1)) je ∆(n^(UnderBar[a]))=a·(n^(UnderBar[a-1])).

DifferenceDelta[FactorialPower[n,a],n]

Antidiference posloupnosti (Subscript[a, n]) je posloupnost (Subscript[b, n]) taková, že ∆(Subscript[b, n])=(Subscript[a, n]). 
Označení: (Subscript[b, n])=(∑_n)(Subscript[a, n]) ("neurčitá suma")
(Subscript[b, n]) není určena jednoznačně (lze přičíst konstantní posloupnost).

DifferenceDelta[n^2,n]

Sum[%,n]

Analogií klasického vzorce ∫(x^a)dx=((x^(a+1))/(a+1)) je (∑_n)(n^(UnderBar[a]))=((n^(UnderBar[a+1]))/(a+1)).

Sum[FactorialPower[n,a],n]

Protože (n^a) lze vyjádřit jako lineární kombinaci (n^(UnderBar[k])), k∈{0,…,a} (koeficienty jsou Stirlingova čísla druhého druhu), dá se snadno najít antidiference k libovolnému polynomu v proměnné n.

Roli exponenciální funkce přebírá (2^n):

DifferenceDelta[2^n,n]

Sum[2^n,n]

Analogie Newtonova-Leibnizova vzorce: Je-li (Subscript[b, n]) antidiference (Subscript[a, n]), pak (∑_(n=min)^max)(Subscript[a, n])=(Subscript[b, max+1])-(Subscript[b, min])

Sum[n^2+3n+2,{n,1,10^20}]

b[n_]=Sum[n^2+3n+2,n]

b[10^20+1]-b[1]

Kreslení grafů

Objekty typu Graph

Neorientované grafy:

Graph[{1<->2,2<->3,3<->4,4<->2}]

InputForm[%]

Popisky u vrcholů:

Graph[{1<->2,2<->3,3<->4,4<->2},VertexLabels->"Name",ImagePadding->10]

Symbol pro neorientovanou hranu: <-> (EscueEsc)

Graph[{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]2}]

Orientované grafy:

Graph[{1->2,2->3,3->4,4->2}]

InputForm[%]

Symbol pro orientovanou hranu: -> (EscdeEsc)

Graph[{1\[DirectedEdge]2,2\[DirectedEdge]3,3\[DirectedEdge]4,4\[DirectedEdge]2}]

Graf s izolovanými vrcholy:

Graph[{1,2,3,4,5},{1->2,2->3,3->4,4->2}]

Zadání pomocí matice sousednosti:

AdjacencyGraph[(({{0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}, {0, 1, 0, 0}}))]

AdjacencyGraph[(({{0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}, {0, 1, 0, 0}})),DirectedEdges->False]

Konstrukce speciálních grafů:

Table[CompleteGraph[i],{i,3,6}]

CompleteGraph[{3,4}]

Table[CycleGraph[i],{i,3,6}]

CompleteKaryTree[3,4,DirectedEdges->True]

GridGraph[{3,6}]

Databáze GraphData

Všechny grafy v databázi:

GraphData[]

Třídy grafů:

GraphData["Classes"]

Grafy v dané třídě:

GraphData["Windmill"]

Konkrétní graf:

GraphData[{"Windmill",{4,4}}]

Vlastnosti grafů:

GraphData["Properties"]

GraphData[{"Windmill",{4,4}},"Connected"]

GraphData[{"Windmill",{4,4}},"Planar"]

GraphData[{"Windmill",{4,4}},"Acyclic"]

Umísťování vrcholů

Automatické rozmístění vrcholů v rovině, algoritmus lze zvolit pomocí GraphLayout:

Manipulate[Graph[{1->4,1->5,1->6,2->4,2->5,2->6,3->4,3->5,3->6},GraphLayout->layout],{layout,{"CircularEmbedding","HighDimensionalEmbedding","LayeredDrawing","RadialDrawing","RandomEmbedding","SpiralEmbedding","SpringEmbedding","SpringElectricalEmbedding"}}]

Explicitní zadání souřadnic vrcholů:

Graph[Range[6],{1->4,1->5,1->6,2->4,2->5,2->6,3->4,3->5,3->6},VertexCoordinates->{{0,(1/2)},{0,1},{0,(3/2)},{1,(1/2)},{1,1},{1,(3/2)}},VertexLabels->"Name",ImagePadding->10]

Vzhled vrcholů a hran

Předdefinované styly grafů:

GraphElementData["GraphStyle"]

Map[CompleteGraph[5,GraphStyle->#,PlotLabel->#]&,%]

Graph[{1->2,2->3,3->4,4->2},GraphStyle->"VintageDiagram"]

Explicitní nastavení vzhledu vrcholů a hran:

Graph[{1->2,2->3,3->4,4->2},VertexSize->0.15,VertexStyle->Green,EdgeStyle->Directive[Black,Thick]]

Pomocí VertexShapeFunction->f lze zadat funkci, která bude obstarávat kreslení vrcholů. Pro každý vrchol se vyhodnotí f[(Subscript[r, k]),(Subscript[v, k])], kde (Subscript[r, k]) jsou souřadnice vrcholu v rovině a (Subscript[v, k]) jeho název.

Graph[{1->2,2->3,3->4,4->2},VertexShapeFunction->({LightBlue,EdgeForm[Black],Disk[#1,0.1],Black,Text[Style[#2,FontFamily->"Arial",FontSize->14],#1]}&)]

EdgeShapeFunction->g je specifikace funkce, která bude obstarávat kreslení hran. Pro každou hranu se vyhodnotí g[{(Subscript[r, i]),(Subscript[r, j])},{(Subscript[v, i]),(Subscript[v, j])},(Subscript[lbl, ij])], kde (Subscript[r, i]), (Subscript[r, j]) jsou souřadnice vrcholů hrany, (Subscript[v, i]) a (Subscript[v, j]) jsou názvy vrcholů, které hrana spojuje, a (Subscript[lbl, ij]) je případný název hrany.

Graph[{1->2,2->3,3->4,4->2},VertexStyle->Red,EdgeShapeFunction->({Blue,Arrow[#1],Arrow[Reverse[#1]]}&)]

Zvýraznění částí grafu

g=Graph[{1->2,2->3,3->4,4->2}]

HighlightGraph[g,{2->3,4}]

HighlightGraph[g,{2->3,4},GraphHighlightStyle->"Thick"]

Grafové algoritmy

Eulerovské tahy

?FindEulerianCycle

FindEulerianCycle[CompleteGraph[5]]

g1=CompleteGraph[7];cycle=First@FindEulerianCycle[g1];Manipulate[HighlightGraph[g1,cycle[[1;;d]],GraphHighlightStyle->"Thick"],{d,0,Length[cycle],1}]

Hamiltonovské kružnice

?FindHamiltonianCycle

Příklad (úloha šachového jezdce):

g2=GraphData[{"Knight",{8,8}}]

cycle=First[FindHamiltonianCycle[g2]]

Manipulate[HighlightGraph[g2,cycle[[1;;d]],GraphHighlightStyle->"Thick"],{d,0,Length[cycle],1}]

Šachovnice nestandardních rozměrů:

knightGraphs=GraphData[{"Knight"}]

Grid[Map[{#,GraphData[#],GraphData[#,"Hamiltonian"]}&,knightGraphs],Dividers->All]

Věta (A. J. Schwenk, 1991): Úloha šachového jezdce na šachovnici m×n, kde m≤n, je řešitelná s výjimkou následujících případů:

a) m, n jsou obě lichá,

b) m∈{1,2,4},

c) m=3 a n∈{4,6,8}.

Maximální párování

FindIndependentEdgeSet hledá maximální párování, tj. co nejvíce hran takových, že žádné dvě nemají společný vrchol.

Given a set of women, each of whom has a preference for some subset of men, find a maximal matching where only matches that agree with preferences are allowed:

g3=Graph[{(Subscript[W, 1])\[UndirectedEdge](Subscript[M, 2]),(Subscript[W, 1])\[UndirectedEdge](Subscript[M, 4]),(Subscript[W, 2])\[UndirectedEdge](Subscript[M, 1]),(Subscript[W, 3])\[UndirectedEdge](Subscript[M, 1]),(Subscript[W, 4])\[UndirectedEdge](Subscript[M, 1]),(Subscript[W, 4])\[UndirectedEdge](Subscript[M, 3])},VertexShapeFunction->"Name",VertexCoordinates->Join[Table[(Subscript[W, i])->{0,i-1},{i,4}],Table[(Subscript[M, j])->{2,j-1},{j,4}]],ImageSize->Small]

matchings=FindIndependentEdgeSet[g3]

HighlightGraph[g3,matchings,GraphHighlightStyle->"Thick"]

Nejkratší cesty v grafu

Graf bez ohodnocených hran:

g=GridGraph[{2,3},VertexLabels->"Name",ImagePadding->10]

FindShortestPath[g,1,6]

HighlightGraph[g,PathGraph@%]

Graf s ohodnocenými hranami:

edges={1<->2,2<->3,3<->4,4<->2,3<->5,4<->5};
weights={5,2,2,6,4,1};
g=Graph[MapThread[Labeled[#1,Framed[#2,RoundingRadius->25,Background->White]]&,{edges,weights}],VertexStyle->Red,EdgeWeight->weights,VertexLabels->"Name",ImagePadding->10]

HighlightGraph[g,PathGraph@FindShortestPath[g,1,5]]

Obarvení mapy čtyřmi barvami

countries=CountryData["SouthAmerica"]

edges=Flatten[Map[Thread[#->CountryData[#,"BorderingCountries"]]&,countries]]

Odstraníme všechny hrany, které vedou do vrcholů mimo countries (zde (Entity["Colombia", Entity["Country","Colombia"], "Entity[\"Country\", \"Colombia\"]", "country"])->(Entity["Panama", Entity["Country","Panama"], "Entity[\"Country\", \"Panama\"]", "country"])).

edges=Cases[edges,(x_->y_)/;MemberQ[countries,x]&&MemberQ[countries,y]]

Pro každou dvojici hran x->y, y->x ponecháme jen jednu z nich:

edges=Cases[edges,(x_->y_)/;Order[x,y]==1]

Graph[edges,GraphLayout->"SpringElectricalEmbedding",VertexLabels->"Name",ImagePadding->30]

Funkce pro barvení grafů se nachází v balíčku Combinatorica.

Needs["Combinatorica`"]

Balíček používá vlastní reprezentaci grafů. Graf můžeme zadat pomocí matice sousednosti, nebo jako seznam hran, kde každá hrana je dvojice vrcholů. Vrcholy musejí být zadány čísly.

rules=Thread[countries->Range[Length[countries]]]

edges/.rules/.{(x_->y_)->{x,y}}

graf2=FromUnorderedPairs[%]

coloring=MinimumVertexColoring[graf2]

capitalLocations=Reverse/@First/@Map[CountryData[#,"CapitalLocation"]&,countries]

polygons=Map[CountryData[#,"Polygon"]&,countries]

nicecolors={Red,Green,Yellow,RGBColor[0.68,0.85,0.9]};

Pozor, balíček Combinatorica obsahuje funkci Graph. Chceme-li použít funkci z jádra, píšeme System`Graph.

Show[Graphics[{EdgeForm[Black],Table[{nicecolors[[coloring[[i]]]],polygons[[i]]},{i,1,Length[countries]}]}],System`Graph[countries,edges,VertexSize->0.5,VertexStyle->Blue,VertexCoordinates->capitalLocations,EdgeStyle->Thick]]

Funkce MinimumVertexColoring, kterou jsme použili, hledá obarvení grafu nejmenším možným počtem barev. Tento algoritmus je použitelný jen pro malé grafy.

V balíčku Combinatorica se nachází také funkce BrelazColoring; u tohoto algoritmu není garantováno, že najde minimální počet barev, je ale velmi rychlý.

BrelazColoring[g]returns a vertex coloring in which vertices are greedily colored with the smallest available color in decreasing order of vertex degree.

Zkusíme pomocí něj obarvit Evropu:

countries=CountryData["Europe"]

edges=Flatten[Map[Thread[#->CountryData[#,"BorderingCountries"]]&,countries]];
edges=Cases[edges,(x_->y_)/;MemberQ[countries,x]&&MemberQ[countries,y]];
edges=Cases[edges,(x_->y_)/;Order[x,y]==1]

graf2=FromUnorderedPairs[edges/.Thread[countries->Range[Length[countries]]]/.{(x_->y_)->{x,y}}]

coloring=BrelazColoring[graf2]

capitalLocations=Reverse/@First/@Map[CountryData[#,"CapitalLocation"]&,countries];
polygons=Map[CountryData[#,"Polygon"]&,countries];

Show[Graphics[{EdgeForm[Black],Table[{nicecolors[[coloring[[i]]]],polygons[[i]]},{i,1,Length[countries]}]}],System`Graph[countries,edges,VertexSize->20,VertexStyle->Blue,VertexCoordinates->capitalLocations,EdgeStyle->Thick(*,VertexLabels->"Name"*)]]

Quit[]

Diskrétní matematika a zpracování obrazu

Průchod bludištěm

Použité zdroje (Wolfram Blog):

Jon McLoone: aMAZEing Image Processing in Mathematica

Jon McLoone: The Battle of the Marlborough Maze at Blenheim Palace Continues

mazeImage=;

bwImage=Binarize[mazeImage]

cleanMaze=DeleteSmallComponents[bwImage,40000]

thinMaze=Thinning[cleanMaze]

prunedMaze=Pruning[thinMaze,∞]

croppedMaze=ImageTake[prunedMaze,350]

pathCoordinates=Position[ImageData[croppedMaze],1]

{start,end}=Cases[pathCoordinates,{350,_}]

pointNeighbors[{x_,y_}]:=Intersection[pathCoordinates,{{x+1,y},{x-1,y},{x,y+1},{x,y-1},{x+1,y+1},{x-1,y-1},{x+1,y-1},{x-1,y+1}}]

graphEdges[{x_,y_}]:=Map[({x,y}\[UndirectedEdge]#)&,pointNeighbors[{x,y}]]

graphEdges[start]

mazeGraph=Graph[pathCoordinates,Union[Map[Sort,Flatten[Map[graphEdges,pathCoordinates]]]],VertexCoordinates->pathCoordinates]

VertexCount[mazeGraph]

mazeSolution=FindShortestPath[mazeGraph,start,end];

{w,h}=ImageDimensions[mazeImage];
transform[{x_,y_}]:={y,h-x}
shortImage=Graphics[{Red,Point[Map[transform,mazeSolution]]}]

Show[mazeImage,shortImage]

TSP umění

Použitý zdroj (Wolfram Blog):

Vitaliy Kaurov: Find Waldo Faster

Here is a portrait computed by FindShortestTour spanning a single line through more than 30,000 points to redraw the Mona Lisa. The idea is quite simple: an image is reduced to only two colors with ColorQuantize, and then FindShortestTour draws a single line through the coordinates of only dark pixels.

monalisa = ;

adjustedML=ImageAdjust[
ColorQuantize[ColorConvert[monalisa,"Grayscale"],2]]

pts=PixelValuePositions[adjustedML,0];
Graphics[Line[pts[[FindShortestTour[pts][[2]]]]]]

So why isn’t it simply a chaos of lines rather than a recognizable image? Because in a shortest tour, connecting closer neighbors is often less costly. Thus, in the Mona Lisa one-liner, there are no segments spanning across large white spaces.