Определение 7.1.1. Графом называется пара G = (V,E) , где V - некоторое конечное множество, элементы которого называются вершинами, а E - семейство неупорядоченных пар (двухэлементных подмножеств) множества V, называемых ребрами. Если пара вершин v и w составляет ребро e = vw, то говорят, что эти вершины смежные или соседние. Также в этом случае говорят, что ребро e и вершина v инцидентны. Наконец, ребра, пересекающиеся по вершине, также называют смежными или соседними.
Замечание 7.1.1. Графы, которые мы только что определили, часто называют простыми. Аналогично определяются ориентированные графы (ребра - упорядоченные пары вершин) и мультиграфы (допускаются петли и кратные, т. е. соединяющие одни и те же вершины, ребра).
Граф G = (V,E) называется взвешенным, если на множестве его ребер задана весовая функция $$\omega : E \to R$$, которая обычно предполагается неотрицательной.
Для продуктивной работы с графами часто требуется визуализировать граф наиболее наглядным образом. Особенно эта проблема важна в случае больших графов. В пакете Mathematica имеется ряд встроенных функций рисования графов на плоскости или в трехмерном пространстве, при котором расположение вершин и форма ребер вычисляется так, чтобы оптимизировать тот или иной "эстетический" функционал.
Перечислим основные функции, используемые в пакете Mathematica для изображения графов, и приведем примеры их использования. Стандартная функция $$GraphPlot[\{v_{i1} \to v_{j1}, v_{i2} \to v_{j2}, \dota \}]$$ строит изображение мультиграфа, при котором вершина $$v_{ik}$$ соединяется ребром с вершиной $$v_{jk}$$:
In[1]:= GraphPlot [{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
При наведении курсора мыши на вершины графа возникают номера этих вершин. Заметьте, что пары {1, 2} встречаются три раза, - это изображено ребром кратности три. Кроме того, имеются петли, заданные двумя парами (4,4) и одной парой (3,3).
Вообще говоря, такое представление естественно для ориентированного графа, хотя приведенное выше изображение игнорировало этот факт. Визуализацию направления ребер можно включить следующей опцией:
In[2] := GraphPlot [{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
DirectedEdges -> True]
Вот еще два формата команды GraphPlot:
$$GraphPlot[\{\{ v_{i1} \to v_{jl}, lbl_1}, \dots \}]$$ приписывает ребру $$v_{ik} \to v_{jk}$$ метку $$lbl_k$$:
In[3]:= GraphPlot[{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
{3 -> 1, "метка"}, 3 -> 2, 4 -> 1, 4 -> 2,
4 -> 4, 4 -> 4}]
GraphPlot[m] строит граф по матрице вершинной смежности, в которой на (i,j)-м месте стоит кратность ребра, идущего из вершины с номером i в вершину с номером j (если ребра нет, то кратность равна нулю). Заметим, что теперь для визуализации петель и кратных ребер нужно специально включать соответствующие опции SelfLoopStyle и MultiedgeStyle, которые по умолчанию выключены.
In[4]:= GraphPlot [{{0, 2, 0, 0}, {1, 0, 0, 0}, {1, 1, 1, 0},
{1, 1, 0, 2}}, DirectedEdges -> True,
SelfLoopStyle -> True, MultiedgeStyle -> True]
In[5]:= GraphPlot [{{0, 2, 0, 0}, {1, 0, 0, 0},
{1, 1, 1, 0}, {1, 1, 0, 2}}]
У команды GraphPlot[m] имеется много опций, с которыми можно ознакомиться, нажав кнопку MORE INFORMATION из Help для GraphPlot.
Команда GraphPlot3D имеет такой же формат, как и GraphPlot, однако изображает графы в трехмерном пространстве.
In[6] :=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
In[7]:=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
А вот пример более симпатичного изображения графа. Здесь опция EdgeRenderingFunction определяет функцию прорисовки ребра (в примере рисуется трубка Tube, ось которой задается последовательными точками ребра, возвращаемыми GraphPlot3D в первый аргумент #1 этой функции, 0.015 - радиус трубки), опция VertexRenderingFunction - функцию прорисовки вершин (они изображаются сферами):
In[8]:=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2,
4 -> 4, 4 -> 4}, SelfLoopStyle -> True,
MultiedgeStyle -> True,
EdgeRenderingFunction -> (Tube[#2, 0.015] ) ,
VertexRenderingFunction -> ({ColorData["Atoms"]
[RandomInteger[{l, 117}]], Sphere[#2, .08]} ) ,
PlotStyle -> Directive[Specularity[White, 20] ] ,
Boxed -> False]
Функция LayeredGraphPlot относится к так называемому иерархическому рисованию и изображает ориентированный граф, располагая вершины на уровнях так, чтобы доминантные вершины (те, в которые входит как можно меньше стрелочек) оказались наверху, а стрелочки были направлены преимущественно вниз. Ниже приведена программа, демонстрирующая, как меняется вид графа при изменении направления ровно одного ребра.
In[9] :=
DynamicModule[{v, w, edge},
v ={1 -> 2, 3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4}; vv= v;
Manipulate[
If [ls ≠ "None", edge = List @@ ToExpression[ls] ;
vv = v / . Rule @@ edge -> Rule @@ (RotateLef t [edge]) ] ;
Row[{LayeredGraphPlot[v, VertexLabeling -> True,
EdgeRenderingFunction ->
(If[(ls ≠ "None") (# == edge) , {Red, Arrowheads[{{Automatic, 0.5}}] ,
Arrow[#2]}, {Blue, Arrowheads[{{Automatic, 0.5}}], Arrow[#1]}] ) ,
ImageSize -> 250] ,
LayeredGraphPlot[vv, VertexLabeling -> True, ImageSize -> 250,
EdgeRenderingFunction ->
(If [(ls ≠ "None") (#2 == RotateLeft[edge]) ,
{Red, Arrowheads [{ {Automatic , 0.5}}], Arrow[#l]},
{Blue, Arrowheads[{{Automatic, 0.5}}], Arrow[#1]}] )]}," " ] ,
{{ls, "None", "ребро"}, { "None" } ≈ Join ≈ (ToString/@ v) } ] ,
UnsavedVariables -> {vv, edge}]
Отметим, что у функции LayeredGraphPlot имеется еще один формат, а именно, LayeredGraphPlot[g,pos] , позволяющий задавать, с какой стороны располагать доминантные вершины. Возможные значения для pos -это Right, Left, Top и Bottom:
In[10] := Manipulate [
LayeredGraphPlot[
{1 -> 2, 1 -> 2, 3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1,
4 -> 2, 4 -> 4},
pos,
VertexLabeling -> True] ,
{
{pos, "Top", "Положение доминантной вершины"},
{Top, Bottom, Left, Right}
}
]
Еще одна иерархическая функция изображения графов - это TreePlot. Несмотря на название, она применима не только к деревьям, но и к графам общего вида (в качестве деревьев у графов берутся LayeredGraphPlot, однако она имеет дополнительный формат TreePlot[g,pos,v_k] , в котором $$v_k$$ обозначает вершину, которую нужно выбрать в качестве корня. Кроме того, pos может принимать еще и значение Center:
In[11] :=Manipulate[TreePlot[{l -< 2, 1 -< 2, 3 -< 1,
3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4},
pos, root, VertexLabeling -> True,
DirectedEdges -> True],
{{pos, Top, "Положение доминантной вершины"},
{Top, Bottom, Left, Right, Center}},
{{root, 1, "Доминантная вершина"}, {1, 2, 3, 4}},
ControlPlacement -> Top]
У всех перечисленных выше функций рисования графов имеется полезная для решения геометрических задач опция VertexCoordinateRules, позволяющая явно указывать координаты вершин графа. Координаты можно задавать или в виде списка, или явно указывать, какой вершине какие координаты приписать, т. е. $$i \to \{х_i, y_i, \dots\}$$. Также вместо некоторых координат может стоять Automatic:
In[12] :=
Manipulate[
graphPlot[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3, 3 -> 1,
3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
VertexCoordinateRules -> p, PlotRange -> { {-1, 2}, {-1, 2}},
AspectRatio -> Automatic, DirectedEdges -> True] ,
{{P, {{0, 0}, {1, 0}, {0, 1}, {1, 1}}}, Locator},
{graphPlot, {GraphPlot, LayeredGraphPlot, TreePlot}}]
In[13] : =
DynamicModule[ {p0 , pp, plnit},
p0 = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};
pInit = p0|[Drop [Range [4] , {1}]]];
Manipulate [plnit = pO[[Drop [Range [4] , {automatic} ] ]] ;
pp = Maplndexed[First[#2] -> #1 ,
Insert[p, {Automatic, Automatic}, automatic]];
Quiet@graphPlot[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
VertexCoordinateRules -> pp, PlotRange -> {{-1, 2}, {-1, 2}},
AspectRatio -> Automatic, DirectedEdges -> True] ,
{{p, plnit}, Locator},
{graphPlot, {GraphPlot, LayeredGraphPlot, TreePlot}},
{{automatic, 1, "Вершина, позиционируемая автоматически"},
{1, 2, 3, 4}}], UnsavedVariables -> {pp, plnit}
]
В пакете Mathematica предусмотрено две группы средств для работы с графами. Одна предназначена для создания, хранения и преобразования информации в виде графов. Другая, с которой мы познакомились в предыдущем разделе, - для визуализации уже имеющихся графов.
Описываемые здесь процедуры являются частью пакета Combinatorica, поэтому перед началом работы с ними следует выполнить команду, загружающую этот пакет:
In[14] := Needs [ "Combinatorica' " ]
Граф в пакете Combinatorica задается командой Graph[<, где каждое ребро (т. е. элемент списка ребер) имеет вид {{<номер вершины>, <номер вершины >},<опции ребра>} , каждая вершина (т. е. элемент списка вершин) имеет вид {{координаты вершины на плоскости\},<опции>} , и, наконец, в списке опций стоят общие команды для всех вершин, всех ребер и графа в целом. Обратим внимание на двойные фигурные скобки, которые объясняются возможным наличием опций.
В пакете Combinatorica также имеются встроенные функции для визуализации графов, такие как ShowGraph[< граф >] или ShowGraphArray.
In[15]:=ShowGraph[Graph[{{{l, 2}}, {{2, 3},
EdgeColor -> Red}, {{3, 1}}}, {{{-1, 0}},
{{1, 1}, VertexColor -> Blue,
VertexStyle -> Disk[Large]}, {{1, 0}}}]]
Более сложный пример. В нем положение вершин задано случайно, а количество и соседство можно регулировать. Кроме того, справа тот же граф перерисован с установкой общих опций, регулирующих вид вершин и ребер. Заметим, что внешние опции, если установлены, перекрывают соответствующие опции, установленные для конкретных вершин (ребер):
In[16] : =
Manipulate [Module [{w, ее, gg} ,
If [k > n- 1, k = n- 1] ;
If [n ≠ Length [w] ,
vv = Map[{#, VertexNumber -> True} , Table [ {Random [] , Random []} , {n}]]];
ее =
Table [{{i, Mod[i + k, n] + 1} , If [Mod [i, 2] = =0, EdgeColor -> Red,
EdgeColor -> Green] } , {i, 1, n} ]; g = Graph [ее, vv] ;
gg = Graph [ее, vv, {EdgeStyle -> edgSt, VertexStyle -> vrSt}] ;
GraphicsRow[{ShowGraph[g], ShowGraph[gg]}]], {{n, 4}, 2, 27, 1},
{{k, 1}, 0, n-1, 1}, {{edgSt, {Green, Red}, "Вид ребра"},
{{Blue} -> "Синий", {Dashed} -> "Пунктир", {Blue, Dashed} -> "Синий-Пунктир" } } ,
{{vrSt, {Disk[Normal]}, "Размер вершины"},
{{Disk[Normal] } -> "Нормальный" , {Disk[Small] } -> "Мелкий" ,
{Disk[Medium] } -> "Средний", {Disk[Large] } -* "Крупный"}},
Initialization: -> (Needs ["Combinatorica" "] )]
Граф, заданный в пакете Combinatorica, можно визуализировать с помощью GraphPlot или GraphPlot3D. Картинка будет куда нагляднее, однако часть информации, такая как цвета ребер и пр., при этом теряется:
In[17] :=Dynamic[GraphPlot3D[g] ]
Отметим, что описанные способы задания графов громоздки и не всегда удобны. Имеется ряд возможностей конструировать графы из более привычных наборов данных, служащих для описания графов. Так можно породить неориентированный граф из списка неупорядоченных пар вершин FromUnorderedPairs[<список>], и ориентированный граф - из списка упорядоченных пар вершин FromOrderedPairs[<список>]. Также граф можно породить из матрицы вершинной смежности FromAdjacencyMatrix[m] и из списков вершинной смежности FromAdjacencyLists[l] :
In [18]:= listOfUnPairs = {{1, 2}, {1, 3}, {1, 4},
{1, 5}, {1, 6}, {2, 3}, {3, 4}, {4, 5},
{5, 6}, {6, 2}};
vc= {{0, 0}} ≈ Join ≈
Map[{Cos[ ((2 π)/5) #] , Sin[((2 π)/5 #]} , Range [5]] ;
g1= FromUnorderedPairs[listOfUnPairs] ;
g11 = FromUnorderedPairs[listOfUnPairs, vc] ;
ShowGraphArray[{gl, gl 1} ]
Отметим, что для такого задания графа координаты вершин, вообще говоря, не нужны. Mathematica сама выберет в качестве них по умолчанию равномерный набор точек на окружности. Последнее, впрочем, не всегда хорошо отражает суть дела. Если нам не нравится выбор Mathematica, то имеется возможность задать точки самим, для чего используется второй необязательный аргумент.
Как мы уже говорили, другой способ получения наглядной картинки - воспользоваться GraphPlot. Использование этой команды, однако, таит в себе некоторые неожиданности. Если, например, включить опции, показывающие направления ребер и их кратность, то мы увидим, что наш неориентированный простой граф воспринимается на самом деле как ориентированный:
In [23] :=GraphicsRow[ {GraphPlot [g1] ,
GraphPlot[g1, DirectedEdges -> True,
MultiedgeStyle -> True] } ]
Из тех же данных можно породить ориентированный граф командой FromOrderedPairs[<список>]:
In[24]=g2 = FromOrderedPairs [listOfUnPairs] ;
g21 = FromOrderedPairs[listOfUnPairs, vc] ;
ShowGraphArray[{g2, g21} ]
Теперь и GraphPlot даст нам тот ориентированный граф, который мы задавали на самом деле:
In [27] := GraphPlot [g2 , DirectedEdges -> True,
MultiedgeStyle -> True]
При помощи команды FromAdjacencyMatrix[m] можно породить как неориентированный граф, так и ориентированный (при этом обязательно выставить опцию Type \to . Directed, иначе получится неориентированный граф, заданный верхним треугольником матрицы смежности). Кроме того, имеется возможность задать граф с
g3 = FromAdjacencyMatrix [m1] ; g31 = FromAdjacencyMatrix [ml, vc] ;
g32 = FromAdjacencyMatrix [m2, vc, Type -> Directed] ;
g33 = FromAdjacencyMatrix [m3 , vc] ;
ShowGraphArray [ {g3 , g31, g32 , gЗЗ}]
In [32] :=
GraphicsRow[ GraphPlot[
#, DirectedEdges -> True, MultiedgeStyle -> True] /@
{gЗ, g32, gЗЗ}]
Наконец, можно задать взвешенный граф, т. е. приписать ребрам графа некоторые числа, называемые весами. Установка опции EdgeWeight порождает взвешенный граф, в чем можно убедиться, выведя Edges. Теперь элементы матрицы интерпретируются как веса. Для отсутствующих ребер следует в этом случае ставить $$\infty$$ (а не нуль).
g34 = FromAdjacencyMatrix[m4, vc, EdgeWeight] ;
el = Edges[g34, EdgeWeight]
Out[35] =
{{{1, 2}, 3}, {{1, 3}, 1}, {{1, 4}, 4}, {{1, 5}, 1}, {{1, 6}, 1},
{{2, 3}, 1}, {{2, 6}, 1}, {{3, 4}, 6}, {{4, 5}, 15}, {{5, 6}, 1}}
Чтобы визуализировать веса ребер взвешенного графа, можно установить значения меток ребер равными соответствующим весам (это делается с помощью команды SetEdgeLabels[<граф>,<список меток>]) и выставить опцию {EdgeLabel \to True}. Обратите внимание: команда SetEdgeLabels не меняет метки исходного графа, а создает новый граф:
In [36] :=g35 = SetEdgeLabels [g34, #[[2]] /@ el] ;
ShowGraphArray[{g35, д34}, {EdgeLabel -> True}]
Кроме того, можно снова воспользоваться GraphPlot, применяя функцию EdgeRenderingFunction для визуализации значений весов ребер. Отметим, что GraphPlot воспринимает графы старого формата так, что каждое ребро учетверяется: две копии ориентированы в одну сторону, а две другие - в другую. Ниже предлагается реализация функции прорисовки ребра, основанная на том, что функция GetEdgeWeights не различает направления ребер:
In[38] :=
GraphPlot [g34 , EdgeRenderingFunction ->
( {Line [#1] , Inset [Style [" " <> ToString @@ GetEdgeWeights [g34 , {#2}] <>" ",
Red, Large] , Mean[#1] , Automatic, Automatic, #1[[1]] - #2[[2]],
Background -> White] } ) ]
Наконец, для задания графов можно воспользоваться списками смежности и командой FromAdjacencyLists. Отметим, что в этих списках также допускается указывать веса ребер. i -м месте стоит список номеров вершин, смежных с i -й вершиной. Если надо указать веса ребер, то в i -м списке вместо номера j ставится пара вида $$\{j, \omega\}$$, где $$\omega$$ - вес ребра ij:
In [39] :=
(*Обычные списки смежности *)
11= {{2, 3, 4, 5, 6}, {1, 3, 6}, {1, 2, 4}, {1, 3, 5} , {1, 4, 6}, {1, 2, 5}};
vc = {{0, 0}} ≈ Join ≈ Map [{cos[((2 π)/5) #] , Sin[((2 π)/5)#]} , Range [5] ] ;
g4 = FromAdjacencyLists [11] ; g41 = FromAdjacencyLists [11, vc] ;
(*Списки смежности с весами *)
lw= {{{2, 1}, {3, 3}, {4, 2}, {5, 1}, {6, 2}}, {{1, 1}, {3, 2}, {6, 3}},
{{1, 3}, {2, 2}, {4, 5}}, {{1, 2}, {3, 5}, {5, 1}}, {{1, 1}, {4, 1}, {6, 6}},
{{1, 2}, {2, 3}, {5, 6}}};
g42 = FromAdjacencyLists[lw, EdgeWeight];
(*Устанавливаем метки ребер равными их весам *)
g43=SetEdgeLabels[g42, #[[2]] /@ Edges[g42, EdgeWeight]];
ShowGraphArray [ {g4 , g41, g43} , VertexNumber -> True , EdgeLabelColor ->Red]
Если граф уже есть, то можно получить из него набор соответствующих (упорядоченных) пар, матрицу смежности, ToUnorderedPairs, ToOrderedPairs, ToAdjacencyMatrix и ToAdjacencyLists, соответственно. При этом надо внимательно следить за опциями. Например, отсутствие опции EdgeWeight приводит к потере информации о весах ребер:
In [46] : =
11= {{{2, 0.1}, {2, π //N}, {3, .13}},
{{2, √3 // N}, {3, Log[2] //N}}, {}};
(*ll={{{2,10},{2, π //N},{3,.13}},{{2, √3 //N},{3,Log[2]//N}},
{}};*)
gr = FromAdjacencyLists[11, EdgeWeight, Type -> Directed];
Row[{ShowGraph[gr, EdgeLabel -> GetEdgeWeights[gr],
EdgeLabelColor -> Red,
EdgeLabelPosition -> {{ .0, .05}, {.1, -.05}, {.05, .05}, \
{.05, .05}, {.05, .05}}],
ToAdjacencyMatrix[gr, EdgeWeight] // MatrixForm,
ToAdjacencyMatrix[gr] //MatrixForm}, Spacer[64]]
Обратите внимание, что при переходе к матрице смежности веса кратных ребер теряются, несмотря на опции (из них берется максимальный). Ориентируемость - сохраняется. Отметим также, что визуализировать веса кратных ребер с помощью меток не тривиально, так как, во-первых, некорректно работает функция SetEdgeLabels и положения меток кратных ребер по умолчанию совпадают:
In [49]:=11= {{{2, .1}, {2, π //N}, {3, .13}},
{{2, √3//N}, {3, Log[2] //N}}, {}};
gr = FromAdjacencyLists[11, EdgeWeight, Type -> Directed];
wgh = GetEdgeWeights[gr]
grr = SetEdgeLabels[gr, wgh] ;
Edges[grr. All]
Out[51] = {0.l, 3.14159, 0.13, 1.73205, 0.693147}
Out[53] = {{{1, 2}, EdgeWeight -> 0 .1, EdgeLabel -> 0.1},
{{1, 2}, EdgeWeight -> 3.14159, EdgeLabel -> 0 .1},
{{1, 3}, EdgeWeight -> 0.13, EdgeLabel -> 0 .13},
{{2, 2}, EdgeWeight -> 1.73205, EdgeLabel -> 1.73205},
{{2, 3}, EdgeWeight -> 0. 693147, EdgeLabel -> 0 . 693147 }}
Во-вторых, некорректно работает функция SetEdgeWeights:
In [54]:=ll= {{2, 2, 3}, {2, 3}, {}} ;
gr = FromAdjacencyLists[11, Type -> Directed];
grr = SetEdgeWeights[gr, { . 1, . 2 , . 3 , . 4 , .5}] ;
Edges[grr, All]
Out[57] = {{{1, 2}, EdgeWeight -> 0.1},
{{1, 2}, EdgeWeight -> 0.1}, {{1, 3}, EdgeWeight -> 0 . 3},
{{2, 2}, EdgeWeight -> 0 . 4 }, {{2, 3}, EdgeWeight -> 0.5}}
Имеется много команд, позволяющих менять уже заданный граф. Вот лишь некоторые из них: AddEdge, AddEdges, AddVertex, AddVertices, DeleteEdge, DeleteEdges, MakeDirected, MakeUndirected, DeleteVertex, ReverseEdges, RemoveMultipleEdges и т. д. (полный список команд содержится в Help, в разделе Constructing Graphs ).
In[58] :=ShowGraphArray[{gll, AddEdges [gll, {{2, 5}, {2, 4}}],
g21, AddEdges [g21, {{2, 5}, {2, 4}}]}]
In [59]:=
gg = DeleteVertex [gll, 1] ; ggl = AddVertex [gg] ;
gg2 = AddEdges[AddVertex[gg] , {{6, 1}, {6, 2}, {6, 3}, {6, 4}}];
GraphicsRow [Framed /@ ShowGraph /@ {gg, ggl, gg2} ]
В этом же разделе Constructing Graphs описаны некоторые операции над графами, способы порождать случайные графы и деревья (см. определение ниже).
Отметим, что, по-видимому, авторы пакета Combinatorica предполагали, вместо непосредственного задания графов, использовать именно построение их из уже имеющихся. Поэтому операции над графами хорошо разработаны и, кроме того, имеется как богатая коллекция встроенных графов, см. Built-in Graphs, так и огромная база GraphData:
In [61] := Manipulate [If [SameQ [h, RandomGraph] , ShowGraph [h [n, 0.5]] ,
ShowGraph[h[n]]],
{{h, EmptyGraph} , {EmptyGraph -> "Пустой", Wheel -> "Колесо",
CompleteGraph -> "Полный" , Hypercube -> "Гиперкуб" ,
RandomGraph -* "Случайный"} , Setter} ,
{{n, 3}, Drop[Range[7] , 2] , PopupMenu} ]
Маршрутом $$\gamma$$ в графе G = (V, E) называется такая последовательность вида $$v_{1e_1v2} \dots v_ke_kv_{k+1}$$, где $$v_i \in V$$ и $$e_i \in E$$, что для каждого $$i,1 < i < k$$, ребро $$e_i$$ соединяет вершину $$v_i$$ с вершиной $$v_{i+1}$$. При этом удобно говорить, что маршрут $$\gamma$$ соединяет вершины $$v_1$$ и $$v_{k+1}$$, и называть такой маршрут $$(v_1,v_{k+1})$$ - маршрутом. Маршрут называется путем, если все его элементы, кроме, быть может, $$v_1$$ и $$v_{k+1}$$, различны. Путь, в котором $$v_1 = v_{k+1}$$, называется циклом Граф называется связным, если для каждых двух его различных вершин $$u$$ и $$v$$ существует ( $$u, v$$ )-маршрут.
Пусть $$G = (V, E) $$ - ориентированный граф. Говорят, что вершина $$v \in V$$ достижима из $$u \in V$$, если существует некоторый (u, v ) -маршрут.
Пусть G = (V, E) - взвешенный граф (ориентированный или нет) весовая функция. Весом маршрута называется сумма весов всех входящих в него ребер. Предположим, что вершина $$v \in V$$ достижима из $$u \in V$$, и рассмотрим множество $$?(u, v) $$ всех (u, v ) -маршрутов в G. Маршрут $$\gamma \in ?(u,v) $$ называется кратчайшим путем, если его вес не превосходит веса любого другого маршрута из ?(u,v) . Оказывается, если весовая функция $$\omega$$ неотрицательна, то существуют полиномиальные (порядка $$n^3$$, где n - количество вершин) алгоритмы поиска кратчайшего пути. В Mathematica реализован известные алгоритмы Dijkstra (для положительных весов), а также BellmanFord (для любых весов). Имеется несколько возможностей использования этих алгоритмов. Чтобы проиллюстрировать это, мы воспользуемся сначала генера
тором случайных графов и случайных весов ребер:
In [62] : = g : = SetEdgeWeights [ RandomGraph [ 17 , . 2 , Type -> Directed] ] ;
SG[g_] := Module [{gg, el},
gg = g;
el = Edges[gg, EdgeWeight] ;
ShowGraph[SetEdgeLabels[gg, #[[2]] /@el] ,
EdgeLabel -> True, EdgeLabelColor -> Green,
VertexLabel -> True, VertexLabelColor -> Red]
];
In [64] :=gcur = g;
SG[gcur]
Отметим, что такая визуализация не очень наглядна. Ниже мы предложим другие картинки, а пока прокомментируем, как работают нужные нам функции.
Команда ShortestPath[<граф>,<начальная вершина>, <конечная вершина>] выдает кратчайший путь в виде списка последовательных вершин:
In [66] :=sp = ShortestPath[gcur, 1, #] /@ Drop [Range [17] , 1]
Out[66] =
{{1, 13, 2}, {1, 13, 2, 3}, {1, 9, 4}, {1, 9, 4, 5},
{1, 9, 4, 6}, {1, 7}, {1, 13, 8}, {1, 9}, {1, 13, 8, 10},
{1, 9, 4, 6, 15, 11}, {1, 9, 12}, {1, 13}, {1, 13, 2, 3, 14},
{1, 9, 4, 6, 15}, {1, 13, 8, 10, 16}, {1, 9, 4, 6, 15, 17}}
Команда Dijkstra[<взвешенный граф>,<вершина>] ищет кратчайшие пути из заданной вершины во все остальные и выдает дерево, составленное из этих кратчайших путей, а также список весов этих путей. Если вершина недостижима, вес пути равен $$\infty$$. Дерево задано списком, на i -м месте которого стоит номер предшественника i -й вершины на ее кратчайшем пути:
In[67] :=dres = Dijkstra [gcur, 1]
Out[67] =
{{1, 13, 2, 9, 4, 4, 1, 13, 1, 8, 15, 9, 1, 3, 6, 10, 15},
{0, 1.11861, 1.2893, 0.958737, 1.17908, 1.34366,
0.391181, 1.08315, 0.811084, 1.27326, 1.6335,
1.38924, 0.692262, 1.6398, 1.34464, 1.48651, 1.41455}}
In [68]:= Column [
{TreePlot[gcur, Center, 1, VertexLabeling -> True,
DirectedEdges -> True,
PlotStyle -> {Arrowheads[{{.02, 0.5}}]}],
LayeredGraphPlot[gcur, VertexLabeling -> True,
DirectedEdges -> True] } , Spacer [4] ]
Эта функция восстанавливает пути, найденные процедурой Dijkstra:
In [69] : = path[end_, start_, dij_] : =
Module[{ic, p, spt} , If[dij[[2, end]] == ∞ , {start},
spt = dij[[l]]; ic = end; p = {end} ;
While [spt[[ic]] \ne start, ic = spt[[ic]]; p= {ic} ≈ Join ≈ p] ;
{start} ≈ Join ≈ p]] ;
In [70] :=path[#, 1, dres] /@ Drop [Range [17] , 1]
Out[70] =
{{1, 13, 2}, {1, 13, 2, 3}, {1, 9, 4}, {1, 9, 4, 5}, {1, 9, 4, 6}, {1, 7},
{1, 13, 8}, {1, 9}, {1, 13, 8, 10}, {1, 9, 4, 6, 15, 11}, {1, 9, 12}, {1, 13},
{1, 13, 2, 3, 14}, {1, 9, 4, 6, 15}, {1, 13, 8, 10, 16}, {1, 9, 4, 6, 15, 17}}
Если забыть про ориентацию ребер, то кратчайшие пути могут измениться, так как возникают дополнительные возможности:
In [71]:=
DynamicModule [ {n = 11, gres = gcur} ,
(*gcur=SetEdgeWeights [ RandomGraph [ 11, . 2 , Type -> Directed] ] ; *)
Manipulate [If [dir, gres = gcur, gres = MakeUndirected [gcur] ] ;
shortPShowL [gcur, ShortestPath [gres, i, j] , i, j , dir] ,
{{i, 1, "Начальная вершина"}, Range[V[gcur]], ControlType -> PopupMenu},
{{j, 2, "Терминальная вершина"}, Range[V[gcur]],
ControlType -> PopupMenu} ,
{{dir, True, "Ориентируемость"}, {True, False}},
SaveDef initions -> True] ,
Initialization : -> (Needs["Combinatorica' "] ;
edgeW[g_, e_] : = GetEdgeWeights [g, {e}][[l]],
shortPShowL[g_, p_, ii_, jj_r test_] : =
Module [{edg, 11, ends, e = 0.1},
edg = Table [Take [p, {i, i + 1}], {i, 1, Length [p] - 1}] ; ends = {ii, Jj} ;
11 = edg ≈ Join ≈ (RotateLeft[#, 1] /@edg) ;
If [Length [p] < 2,
Show[{Graphics[Text[Style["Путей НЕТ", Red, Bold, Large] , {0, 0}] ] ,
LayeredGraphPlot[g,
EdgeRenderingFunction ->
(If [test, {Black, Arrowheads[{{.02 , 0.5}}], Arrow[#1]},
{Black, Line[#l]}] ),
VertexRenderingFunction ->
({If[MemberQ[ends, #2] , Pink, White] , EdgeForm[Black] ,
Disk[#, .5] , Black, Text[#2, #1]} ) , ImageSize -> 600]
}],
LayeredGraphPlot [cr, EdgeRenderingFunction ->
(If[MemberQ[ll, #2], {Red}, {Orange, Opacity[0.5]}] ≈
Join ≈ If [test, {Arrowheads [{{ .02, 0.5}}], Arrow[#1]} ,
{Line [#1]}] ),
VertexRenderingFunction ->
({Which [MemberQ [ends, #2] , Pink, MemberQ[p, #2] , LightBlue,
True, White], EdgeForm[Black], Disk[#, .5], Black,
Text[#2, #1]} ) , ImageSize -> 600] ] ])]
Если ShortestPath. Для визуализации воспользуемся продвинутыми возможностями GraphPlot3D. Ребра изобразим в виде разноцветных цилиндров разной толщины. Толщина и цвет зависят от веса. Ребра кратчайшего пути выделены матовым красным. Номера концевых вершин пути - черные, промежуточных вершин - синие. Напомним, что, двигая мышкой при нажатой клавише Alt, можно приблизить/удалить объект, а при нажатой клавише Shift - сместить его в сторону:
In [72] :=
DynamicModule[{},
(*gcur=SetEdgeWeights[ RandomGraph[11, . 2,Type -> Directed]];*)
Manipulate[shortPathShow[gcur, ShortestPath[gcur, i, j], r] ,
{{i , 1} , Range[V[gcur]] , ControlType -> PopupMenu},
{{j 2}, Range[V[gcur]] , ControlType -> PopupMenu},
{{r, 0.1}, 0.01, 0.4}, SaveDefinitions -> True] ,
Initialization: -> (Needs [ "Combinatorica" ] ;
edgeWeight[g_, e_] : = GetEdgeWeights[g, {e}];
shortPathShow[g_ , p_ , r_ ] :=
Module[{edg, 11, ends, 6 = 0.1},
edg = Table [ Take [p, {i, i + 1}], {i, 1, Length[p] -1}] ;
ends = {pill, Pl-l]};
11 = edg≈ Join ≈ (RotateLef t [# , 1] /@ edg) ;
If[Length[p] < 2,
Show[
{Graphics3D[Text[Style["Нет пути!", Red, Bold, Large],
{0, 0, 0}]] ,
GraphPlot3D[g,
EdgeRenderingFunction ->
({Hue[edgeWeight[g, #2]] ,
Cylinder [#1, r edgeWeight [g, #2]]} ) ,
VertexRenderingFunction ->
({Yellow, Sphere [#1, r + 0.03],
Text[Style[#2, Green, Bold, Large],
#1+ {e , e, e}]} ), ImageSize -> 500,
Viewpoint -> {3.25, 0.57, 3.25}]
}],
GraphPlot3D[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2] , {Glow[Black] , Red},
{Lighter [Hue [edgeWeight [gr, #2]], .5]}] ≈ Join ≈
{Cylinder[#l, Max [r edgeWeight [g, #2], 0.01]]} ) ,
VertexRenderingFunction ->
({If [MemberQ[p, #2 , Red, Yellow] , Sphere [#1, r + 0.03] ,
Text[Style[#2, Which[MemberQ[ends, #2], Black,
MemberQ[p, #2] , Blue, True, Green], Bold, Large] ,
#1 + {e, e , e} ] } ) , Boxed -> False, ImageSize -> 500 ,
Viewpoint -> {3.25, 0.57, 3.25}]
]])]
В следующем варианте картинка двумерная, веса ребер снова проиллюстрированы их толщиной. Зато хорошо видны стрелки:
In [73] : =
DynamicModule[{n = 11},
Manipulate[shortPShow[gcur, ShortestPath[gcur, i, j],
if jf r] , {{i, 1} , Range [V [gcur]] ,
ControlType -> PopupMenu} ,
{{j, 2} , Range[V[gcur]], ControlType -> PopupMenu},
{{r, 0.003}, 0.003, .01}, SaveDefinitions -> True],
Initialization : -> (Needs [ "Combinatorica' " ] ;
edgeW[g_, e_] : = GetEdgeWeights [g, {e}][[l]];
shortPShow [g_, p_, H_, jj_t *_] : =
Module[{edg, 11, ends, 6 = 0.1},
edg = Table [Takefp, {i, i + 1}], {i, 1, Length [p] - 1}] ;
ends = {ii, jj) ;
11 = edg ≈ Join ≈ (RotateLef t [#, 1] /@ edg) ;
If[Length[p] < 2,
Show[
{Graphics[Text[Style["Путей НЕТ", Red, Bold, Large],
{0, 0}]],
GraphPlot[g,
EdgeRenderingFunction ->
({Black, Arrowheads[{{0.02, 0.5}}] ,
Arrow[#l]} ),
VertexRenderingFunction ->
({If[MemberQfends, #2] , Pink, White],
EdgeForm[Black] , Disk[#, .1] , Black,
Text [#2, #l } ) , ImageSize -> 500]
}],
GraphPlot[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2], {Blue},
{Orange, Opacity[0.5]}] ≈ Join ≈
{Thickness [r edgeW[g, #2]],
Arrowheads [{{3 r , 0.5}}] , Arrow [#l, .1]} ) ,
VertexRenderingFunction ->
( {Which [MemberQ [ends, #2] , Pink, MemberQ[p, #2],
LightBlue, True, White], EdgeForm[Black],
Opacity[0.7], Disk[#, .1] , Opacity[1] ,
Black, Text[#2, #l] } ) , ImageSize -> 500]
]])]
Связный граф без циклов называется деревом. Понятие
Подграфом H в графе $$G = (V_G, E_G) $$ называется такой граф $$H = (V_H, E_H) $$, что $$V_H \subset V_G$$ и $$E_H \subset E_G$$. Если граф G - взвешенный с весовой функцией $$\omega$$, то для каждого его подграфа H естественно определяется его вес, равный сумме весов всех ребер этого подграфа.
Подграф $$H \subset G$$ называется остовным, если $$V_H = V_G$$. В каждом связном графе, очевидно, имеется остовный подграф, являющийся деревом. Такие подграфы называются остовными деревьями. Количество разных
Остовное дерево наименьшего веса в связном взвешенном графе называется минимальным остовным деревом Несмотря на упомянутую оценку, имеются полиномиальные алгоритмы построения минимальных
Пусть G = (V,E) - связный взвешенный граф с весовой функцией $$\omega$$. Определим граф $$T_0 = (V, \varnothing) $$. На $$i$$ -м шаге, $$1 \le i \le n - 1$$, среди всех ребер, добавление которых к $$T_{n-1}$$ порождает ацикличный граф, выберем ребро наименьшего веса и добавим к $$T_{i-1}$$ получив тем самым $$T_i$$. Алгоритм заканчивает работу, построив граф $$T_{n-1}$$, который и является минимальным остовным деревом.
В пакете Combinatorica имеется команда MinimumSpanningTree[<граф>], возвращающая минимальное остовное дерево в формате Graph.
Снова нарисуем красивые картинки:
In[74] :=
DynamicModule[{gu, gcur, mst, n = 11},
gu = RandomGraph[n, . 6] ;
While [! ConnectedQ[gu], gu = RandomGraph[n, . 6] ] ;
gcur = SetEdgeWeights[gu];
mst = MinimumSpanningTree[gcur];
Manipulate[plot3DWGraph[gcur, Edges[mst], r,
{Glow[Red], Brown}], {r, 0.01, 0.2}],
Initialization : -> (Needs [ "Combinatorica" " ] ;
edgeWeight [ g_, e_] : = GetEdgeWeights [g, {e}];
plot3DWGraph[g_, 1_, r_, col_, op_:l] := Module[ {11} ,
11 = 1≈ Join ≈ (RotateLeft[#, 1] /@ 1) ;
GraphPlot3D[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2] , col,
{Lighter[Hue[edgeWeight[g, #2]], .9],
Opacity[op]}]≈ Join ≈
{Cylinder[#2, Max [ r edgeWeight [ g, #2], 0.01]]} ) ,
VertexRenderingFunction ->
({Yellow, Sphere[#, r+ 0.03]} ) , Boxed -> False] ] ) ]
In[75] :=
DynamicModule[{gu, gcur, mst, n = 11},
gu = RandomGraph[n, . 6] ;
While[! ConnectedQfgu], gu = RandomGraph[n, . 6] ] ;
gcur = SetEdgeWeights[gu];
mst = MinimumSpanningTree[gcur] ;
Manipulate[plotWGraph[gcur, Edges[mst], r, Red, Orange],
{r, 0.01, 0.1}],
Initialization : -> (Needs ["Combinatorica" "] ;
edgeW[g_, e_] : = GetEdgeWeights[g, {e}][[l]];
plotWGraph[g_, 1_, r_, coll_, col2_] :=Module[{11},
11 = l ≈ Join ≈ (RotateLeft[#, 1] /@1) ;
GraphPlot[g, EdgeRenderingFunction ->
(If [MemberQ[ll, #2], {col1, Thickness [r edgeW[g, #2]],
Line[#2]}, {col2, Thickness [r edgeW[g, #2]],
Opacity[0. 4] , Line[#2]}] ),
VertexLabeling -> True] ] ) ]
Если множество вершин графа содержится в
In[76] : =
DynamicModule[{pts, pCG, pts0, w, mst, ее, delauney, showTr},
pts0= {{1, 0}, {0, 1}, {-1, 0}};
Manipulate [vv = Map[{#, VertexNumber -> True} , pts] ;
pCG = SetEdgeWeights [Graph [CompleteGraph [Length[pts] ] [[!]] , vv] ,
WeightingFunction -> Euclidean] ;
mst = MinimumSpanningTree[pCG]; ее = Edges[mst];
delauney = FromAdjacencyLists [#[[2]] /@ DelaunayTriangulation [pts] ] ;
Show[If[showTr, {showCG[Length[pts], pts, ее],
showGr[delauney, pts, {Black}]}, showCG[Length[pts], pts, ее]] ,
PlotRange -> {{-2, 2}, {-2, 2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True} ,
{{showTr, False, "Показать триангуляцию Делоне"}, {True, False}}],
Initialization: -> (Needs [ "Combinatorica'"] ;
Needs["ComputationalGeometry'"];
showCG [ n_, v_, edg_: { } ] : =
Graphics[GraphicsComplex[v,
If [MemberQ [edg, #11]]], {Red, Thickness [0 . 015] , Opacity [0 . 7] ,
Line[#[[l]]] } , {Blue, Dotted, Line [#[[1]] ] } ] /@
CompleteGraph [n] [[1]] ] ] ;
showGr[g_, v_, col_: {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line[Edges[g] ] ]]];)]
Триангуляция Делоне тесно связана с так называемой диаграммой Вороного конечного подмножества M евклидова пространства. Если $$M = \{m_1, \dots ,m_п\}, n \ge 2$$, то ячейкой Вороного точки $$m_i$$ называется множество $$W(m_i) = \{x| \rho (m_i,x) \le \rho (m_j,x) $$ для всех $$j\}$$, где через $$\rho$$, как и выше, обозначена функция расстояния. Ячейки Вороного точек двухточечного множества $$M = \{m_1,m_2\}$$ - суть полупространства (в двумерном случае - полуплоскости), порожденные серединным перпендикуляром к отрезку $$[m_1, m_2] $$. В общем случае - это выпуклые многогранные области, полученные пересечением соответствующих полупространств:
In[77] :=
Manipulate[DiagramPlot[ pp] ,
{(pp/ {{0, 0}/ {1- 0}}}, Locator, LocatorAutoCreate -> True}]
Триангуляция Делоне - это граф на множестве точек M евклидова пространства, две вершины которого соединены ребром-отрезком, если и только если ячейки Вороного этих вершин пересекаются по множеству коразмерности один. В случае плоскости - по отрезку или лучу.
In[78] : =
DynamicModule[{pts, pts0, vor, delauney},
pts0= {{1, 0}, {0, 1}, {-1, 0}, {0, -1}};
Manipulate[
delauney = FromAdjacencyLists [#|[2]] /@ DelaunayTriangulation[pts] ] ;
Show[{showDiaG[pts], showGr[delauney, pts, {Blue}]},
PlotRange -> {{-2, 2}, {-2,2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True}] ,
Initialization: -> (Needs [ "Combinatorica"'" ] ;
Needs["ComputationalGeometry'" ] ;
pairs [ls_] := Table [{Is [i] , Is |[i + 1]] } , {i , 1, Length [Is] - 1} ] ;
showGr[g_, v_f col_: {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line [Edges [gr] ] ] ] ] ;
showDiaGfpp ] := Module [ {hh, vd, In, edg, rs, els},
vd = VoronoiDiagram [pp] ; hh = Head[#] /@ vd[[l]| ;
In =
Union[
Sort /@ Flatten [pairs [#] /@
Select [ Table [ Select [vd [[2, i, 2] , hh[[#]| == List ] ,
{i, 1, Length [vd [[2]] }] , Length[#] > 1 ] , 1] ] ;
edg = Line[vd[[1]][[#]] ] /@ In; rs = Select [vd[[l]] , Head[#] == Ray ] ;
Graphics [edg ≈ Join ≈ (Line /@ Apply [List, rs , {1}])]];)]
На следующей картинке ячейки Вороного раскрашены в разные цвета:
In[79] :=
DynamicModule [ {pts, pts0, vor, delauney},
pts0 = {{1, 0}, {0, 1}, {-1, 0}, {0, -1}};
Manipulate[
delauney = FromAdjacencyLists[#[[2]] /@ DelaunayTriangulation[pts]] ;
Show[{showDia[pts], showGr[delauney, pts, {Blue}]},
PlotRange -> {{-2, 2} , {-2, 2}}] , {{pts, pts0}, Locator, LocatorAutoCreate -> True}] ,
Initialization: -> (Needs [ "Combinatorica" " ] ;
Needs["ComputationalGeometry'"];
showGr[g_ , v_ , col_ : {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line [Edges [g]] ] ] ] ;
append[l_, r_] := Module [ {bg, en, res},
If [Length[r] ≠ 4, res = 1 ≈ Join ≈ r,
bg = r[[{l, 2}];
en = r[[{3, 4}];
Which[
bg[[1]] == 1[l] , res = {bgI2]; bgPI } ≈ Join ≈ 1,
bg[[2]] == 1[[l] , res = bg ≈ Join ≈ 1,
bg[[1]] == 1[[-l]], res = l ≈ Join ≈ bg,
bg[[2]] == 1[[-1]], res = 1 ≈ Join ≈{bg[[2]] , bg[[1]]}
];
Which[
en[[1]] ==1[[1]], res = {enI2I , en III }≈ Join ≈res ,
en[[2]] == 1[[1]], res = en ≈ Join ≈ res,
en[[1]] ==1[[-1]], res = res ≈ Join ≈ en,
en[[2]] ==1[[-1]], res = res ≈ Join ≈ {en[[2]], en[[1]]]}]
];
res
];
showDia[pp_] : = Module[{hh, vd. In, rs, els, pi},
vd = VoronoiDiagram[pp] ; hh = Head[#] /@vdlll ;
ln = vdIlH#I /@ Table [Select [vd[2, i, 2]| , hhl#] == List S] ,
{i, 1, Length[vdI2J]}];
rs = Map[If [Length[#] > 0, Flatten [Apply [List, it, 1] , 1] , {}] ,
vd[[1]][[#]] /@ Table [Select [vd [[2, i, 2]], hh[[#]] == Ray ] ,
{i, 1, Length[vd[[2]] ]}]] ;
cls = MapThread[append[#1, #2] , {In, rs}] ; pi = Polygon[#] /@ cls;
Graphics[Table[{EdgeForm[{Thick, Dashed}],
ColorData[Length[pp], "ColorList"][[i]], Opacity[0.7],
pl[[i]], Black, PointSize[0.02] , Point[pp[[i]] ] } ,
{i, 1, Length [pp]}]]];
)
]
Возвращаясь к задаче о ЕМОД, с помощью триангуляции Делоне можно построить квадратичный (по количеству вершин) алгоритм построения ЕМОД. А именно, сначала строим триангуляцию Делоне, а затем уже к ней применяем алгоритм Краскала:
In [80] : =
DynamicModule[{pts, ptsO, mst, ее, delauney, showTr},
pts0= {{1, 0}, {0, 1}, {-1, 0}};
showGr[g_, v_, col_: {Blue}] : =
Graphics [GraphicsComplex[v, Append [ col, Line [Edges [g-] ] ]]];
Manipulate[
delauney = SetEdgeWeights[
FromAdjacencyLists [#[[2]] /@ DelaunayTriangulation [pts] , pts] ,
WeightingFunction -> Euclidean] ;
mst = MinimumSpanningTree[delauney] ;
Show[
If[showTr, {showGr[mst, pts, {Red, Thickness[0.01], Opacity[0.7]}],
showGr[delauney, pts, {Blue}]},
showGr[mst, pts, {Red, Thickness[0.01]}]],
PlotRange ->
{{-2, 2}, {-2, 2}}], {{pts, pts0}, Locator, LocatorAutoCreate -> True} ,
{{showTr, False, "Показать триангуляцию Делоне"}, {True, False}}],
Initialization : -> (Needs [ "Combinatorica' " ] ;
Needs["ComputationalGeometry *"])
]
Замечание 7.3.1. На самом деле в общем случае алгоритм Краскала построения МОД работает со скоростью $$|E|ln|E|$$, а алгоритм построения ЕМОД, использующий триангуляцию Делоне, - со скоростью $$|V |ln|V |$$.
В качестве примера построим минимальные Mathematica включает в себя большие базы данных по естественным наукам, в частности, по географии. Эти базы данных, впрочем, находятся на сайте компании Wolfram, поэтому, чтобы ими пользоваться непосредственно, нужен доступ к сети. В приведенных примерах мы просто выкачали информацию о геометрической форме страны и ее флаге из базы CountryData, и координаты и названия крупных (больше 100000 жителей) городов выбранных стран из базы CityData. Отметим также наличие баз данных по молекулярной биологии, астрономии, физике, химии, лингвистике, финансам и пр. (см. Scientific Technical Data ).
In[81] : =
germCitiesCoord = {{{52.52 ", 13.38 "}}, {{53.55 ", 10. '}}{* ... *) } ;
ukCitiesCoord = {{{51.5", -0.1166667"}}, {{52.4666667", -1.9166667"}}
(* . . . *)};
germCitiesNames = {"Berlin", "Hamburg", "Munich", "Cologne" (* ... *)};
ukCitiesNames = {"London", "Birmingham", "Glasgow", "Liverpool" (* ... *)};
germPoly =
Polygon[{{{5.90725', 50.7242'}, {6.02985', 50.8203'}, {6.07395', 50.8833'},
{6.08445', 50.9323}, {6.05505', 50.9715}, {6.02985', 50.9785}
(* ... *)}, {{13.9187', 53.886'}, {13.8735', 53.8918},
{13.87', 53.9166'} (. ... *)} (* ... *)}];
ukPolygon =
Polygon[{{{-5.80035', 55.3191'}, {-5.83335', 55.3252'},
{-5.8559', 55.3505'}},
{{-7.1481', 55.1193-}, {-7.1613', 55.0969'}, {-7.154', 55.0852}
(* ... *)} (* ... * }];
sph[v_] := {Cos [v[[ll] Degree] Cos [v|[2]] Degree] ,
Cos [v[[ll] Degree] Sin [v[[2I] Degree] , Sin[v[[ll] Degree] } ;
geoDist[a_, b_] := N[2 ArcSin [Norm [sph [afl2]] ] - sph[b[[2]j] ] /2] ] ;
Needs["Combinatoricav"];
geoMST [ cnt_] : =
Module[{cts, ctsT, names, flag, poly, edges, gWeight, mst, col},
If[cnt == "Germany", cts = germCitiesCoord; names = germCitiesNames;
flag = gflag; col = LightOrange; poly = germPoly, cts = ukCitiesCoord;
names = ukCitiesNames; flag = ukflag; poly = ukPolygon; col = LightGray];
edges = Edges[CompleteGraph[Length[cts]] , All] ;
gWeight = SetEdgeWeights[Graph[edges, cts] , WeightingFunction -> geoDist] ;
mst = Edges[MinimumSpanningTree[gWeight]] ;
ctsT = Reverse /@ Flatten [cts, 1] ;
Graphics[{col, EdgeForm[Black], poly, Thick, Green,
MapThread[Line[{#2, 2}] , {ctsT[I^[[l]]I /@mst, ctsT[I#[[2I]I /@ mst}],
PointSize [Medium] , Red,
MapThread [Tooltip [Point [#1] , #2] , {ctsT, names}] ,
Inset[flag, {Right, Top}, {Right, Top}, 2]}]
];
GraphicsRow [geoMST [#] /@ { "Germany" , "UnitedKingdom" } ]
Также очень популярной является так называемая задача коммивояжера, состоящая в том, чтобы найти Mathematica реализован ряд приближенных методов решения задачи о коммивояжере, дающих точный ответ для малого числа вершин. Соответствующая функция называется FindShortestTour. По умолчанию весовая функция -
In [94] :=
Manipulate[
Graphics [
Line [р[[# ≈ Join ≈ {#[[1]]} @ Last [FindShortestTour [p] ]] ] ] ,
PlotRange -> {{-2, 2}, {-2, 2}}] ,
{{p, {{0, 1}, {1, 0}, {1, 1}}}, Locator,
LocatorAutoCreate -> True} ]
Снова пользуясь географическими базами данных, можно получить, например, такую картинку, описывающую оптимальный маршрут посещения всех стран мира:
С помощью триангуляции Делоне и диаграммы Вороного также легко решается, например, известная задача о ближайших соседях. А именно, ближайшими соседями точки $$m_i$$ из подмножества $$М =\{m_1 ,\dots, m_n\}$$ М на подмножества, составленные, в некотором смысле, из "близких" точек. Один из подходов состоит в
In [95] :=
DynamicModule[{pts, pts0, neibs},
pts0 = {{-1, -1}, {1, 0}, {0, 0}, {0, 1}, {1, 1}};
Manipulate[neibs = FromOrderedPairs[adLists[pts]];
Show[showOrGr[neibs, pts], PlotRange -> { { - 2 , 2}, {-2, 2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True}],
Initialization:-> (Needs["Combinatorica""] ;
Needs["ComputationalGeometry' "];
showOrGr[g_, v_] :=
Module[{cmp}, cmp = WeaklyConnectedComponents[g] ;
Graphics[GraphicsComplex[ v,
{ColorData[3, "ColorList"] [[
Mod [Position [cmp, #[[1]] ] [[1, 1]], 10] + 1] ,
Arrow[#]}/@ Edges[g] ]]];
nearNeib[pts_, i_] := Module [ {delauney, min, dist} ,
delauney = #[[2]] /@ DelaunayTriangulation [pts] ;
dist = Norm [pts[[i]] - pts[[#]] ] /@ delauneyjij ;
min = Min[dist] ;
delauney[[i, Flatten[Position[dist, min] ] ]] ] ;
adLists[pts_] : =
Module[{nb, f},
nb = nearNeib [pts, #] /@ Range [Length [pts] ] ;
f [x_, y_] := {x, #} /@y;
Flatten[MapThread[f, {Range[Length[pts]], nb}] , 1]])]
Еще один пример оптимизационной задачи - знаменитая проблема Штейнера. На практике такая задача возникает при проектировании коммуникационных сетей, например, сети дорог, связывающей данные населенные пункты, или сети проводников, соединяющих различные элементы микросхемы. Обычно требуется, чтобы полученная сеть была оптимальна, скажем, имела наименьшую возможную длину. Похожую задачу мы уже разбирали, говоря о минимальном
Простейший вариант проблемы Штейнера известен как задача Ферма: построить на евклидовой плоскости такую точку, чтобы суммарное расстояние от нее до заданных трех точек, называемых терминалами, была наименьшей возможной. Ниже приведена визуализация решения этой задачи, причем терминалы задаются локаторами. Поэкспериментируйте с положением локаторов и попробуйте сформулировать определяющее свойство полученной сети:
In [96] : =
Manipulate[Module[{х, у, s},
s=
{х, у} /.
Las t@Quiet@FindMinimum [Plus @@ (Norm[{x, y} - #] /@p) ,
{{x, First©Mean[p]} , {y, Last@Mean[p]}} ,
Method -> "PrincipalAxis"];
Graphics [Line [{s, #}] /@p, PlotRange -> { {-2, 2}, {-1, 2}},
AspectRatio -> Automatic] ] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Внимательное изучение поведения сети показывает, что пока все три отрезка невырождены, углы между ними равны между собой и, значит, равны $$120^0$$, а когда один из отрезков вырождается, то угол между оставшимися отрезками не становится меньше, т.е. остается больше или равен $$120^0$$. Кроме того, дополнительные вершины не могут иметь степень 1 или 2. На самом деле это действительно так, причем даже в общем случае. Ниже приведен пример кратчайшей сети для четырех терминалов, как на плоскости, так и в трехмерном пространстве:
In [97] : = Manipulate [
Module {gl, g2, g3, g, xl, yl, x2, y2, min, res, resl, gr, sub, v,
e, st, dist, MyShowGraph},
$$\begin{matrix}
dist[v_{-}, w_{-}] : = \sqrt{(v - w) . (v - w)} ;
\end{matrix}
$$st[gr_, ls_] : =
Quiet@Module [ {w, ее, len} , vv = Vertices [g] ; ее = Edges[g] ;
len = Plus @@ (dist @@ vv[[#]] /@ ее) ;
FindMinimum [ len, {#, RandomReal [ ] } /@ Flatten[vv[[ls]]] ,
Method -> "PrincipalAxis"] ≈ Join ≈ {g}] ;
MyShowGraph[g_, opts : OptionsPattern[Graphics]] :=
Module[{vv, ее} , vv = Vertices[g]; ее = Edges[g] ;
Graphics [Line [vv[#] ] /@ ee, opts]] ;
gl = Graph[{{{l, 5}}, {{2, 5}}, {{5, 6}}, {{6, 3}}, {{6, 4}}},
({#} S/вр) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}];
g2 = Graph[{{{l, 5}}, {{3, 5}}, {{5, 6}}, {{6, 2}}, {{6, 4}}},
({#} S/ep) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}] ;
g3 = Graph[{{{l, 5}}, {{4, 5}}, {{5, 6}}, {{6, 3}}, {{6, 2}}},
({#} S/вр) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}] ;
g = {gl, g2, g3};
res = st[*f, {5, 6}] /@g;
min = Min[#|[l]] /@res] ;
resl = Select [res, #|[1]] == min ] // First;
gr = resl // Last;
sub = reslI2J; v = Vertices[gr] / . sub;
e = Edges [gr] ;
MyShowGraph [AddEdges [AddVertices [EmptyGraph [0] , v] , e] ,
PlotRange -> {{-2, 2}, {-2, 2}}]
],
{{p, {{-1, 1}, {-1, -1}, {1, -1}, {1, 1}}}, Locator},
Initialization : -> (
Needs["Combinatoricav"];
)
]
Замечание об управлении. При наведении курсора на граничную (красную) вершину сети (см. ниже), вершина становится желтой. Чтобы выделить граничную вершину сети, позиционируйте курсор на этой вершине и нажмите Ctrl. Вершина станет зеленой, "прикрепится" к курсору мыши и будет следовать за ним. Чтобы отпустить вершину, нажмите Shift. Вершина вновь станет красной. Нажимая левую клавишу мыши при курсоре, позиционированном на картинке, и двигая курсор, вы будете вращать картинку. Обратите внимание на скачкообразные перестройки структуры сети (
In [98]:=
DynamicModule[{pp, Locator3D, MyMean, testPoint, st, net4},
Locator3D[pts0_, ?_: Line] : =
DynamicModule [{pts, ppp, cur, с = False, covered = False, g, msAlt, bds, bm=-l,
bM = 1, ptsAlt, i - 1, testln = 2} ,
pts = pts0; ptsAlt = {0, 0, 0} ; msAlt ={{1.3, -2.4, 2.}, {-1.3, 2.4, -2.}};
cur = Dynamic[MousePosition["Graphics3DBoxIntercepts", msAlt]];
g=Graphics3D[Map[{Red, Sphere[#, 0.05]} ,
If [c, Drop[pts, {3}], pts] ] ≈ Join ≈
Table[
If [CurrentValue ["ControlKey"] bbcovered, с = True; msAlt = #; ptsAlt = pts[[j]] ;
If[CurrentValue["ShiftKey"], с = False];
testln = Length[CurrentValue[{"MousePosition", "GraphicsImageScaled"} ] ] ;
If [c, If [testln < 2, ptslij = ptsAlt] ;
bds = Transpose [AbsoluteOptions [g, PlotRange] [[1, 2]] ];
bm = 0 . 7 bds [[1]] ;
bM = 0 . 7 bds [[2]] ;
ppp = MyMean [pts [[j]] , #] ;
pts[[j]] = MapThread[Max[Min[#I, #3] , #2] , {ppp, bm, bМ}];
ptsAlt = pts[[j]];
msAlt = #] ;
If [c, If [i == j, {Green, Sphere[pts[[i]] , 0.07]}, {}],
If [ (testln >= 2) (testPoint[pts[[i]] , #] < 0.01 ) , covered = True; j = i;
{Yellow, Sphere[pts[[i]], 0.07]}, covered=False; {}]],
{i , 1, Length [pts] } ] ≈ Join ≈ {f[pts] } /@ cur,
Boxed -> True, PlotRange -> ({-1.3, 1.3}, {-1.3, 1.3}, {-1.3, 1.3}}],
Initialization : -> (
$$\begin{matrix}
MyMean[p_{-} , ms_{-} ] :=ms[[1]]+(ms[[2]]-ms[[1]]) \frac{(ms[[2]]-ms[[1]]).(p-ms[[1]])}{(ms[[2]]-ms[[1]]).(ms[[2]]-ms[[1]])};
\end{matrix}\\
\begin{matrix}
testPoint[p_{-}, ms_{-}] : =
\end{matrix}\\
\begin{matrix}
Module[\{v\}, v = p - ms[[1]]-(ms[[2]]-ms[[1]])\frac{(ms[[2]]-ms[[1]]).(p-ms[[1]])}{(ms[[2]]-ms[[1]]).(ms[[2]]-ms[[1]])};v.v];
\end{matrix}
$$)];
st[gr_, ls_] : =
Quiet@Module [{vv, ее, len} , vv = First @g; ее = Last@g;
len = Plus @@ (EuclideanDistance @@ vv[[#]] /@ee);
FindMinimum [ len, {#, RandomReal [ ] } /@ Flatten [w[[ls]] ] , Method -> "PrincipalAxis"]≈
Join ≈ {g-}] ;
net4[p_] := Module [ {gl, g2 , g3, gg, res, min, resl, gr, sub, v, e, xl, yl, zl, x2 , y2 , z2},
gl = {(# , /@p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}} ,
{{1, 5}, {2, 5}, {5, 6}, (6, 3}, {6, 4}}};
g2 = { (# /@p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}},
{{1, 5}, {3, 5}, {5, 6}, {6, 2}, {6, 4}}};
g3 = { (# /@ p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}},
{{1, 5}, {4, 5}, (5, 6), {6, 3}, (6, 2}}};
gg = {gl, g2, g3} ; res = st[#, {5, 6}] /@gg; min = Min[#[[l]] /@ res] ;
resl = Select[res, #[[1]] == min ] // First; gr = resl // Last; sub = resl[[2]] ;
v = First@gr /. sub;
e = Last@gr;
Line[v[[#]] ] , /@ e] ;
рр={{-1, 0, -1}, {-1, 0, 0}, {-1, 1, 0}, {1/2, 1/2, 1/2}};
рр={{-1, 0, -1), {-1, 0, 0}, {-1, 1, 0}, {1/2, 1/2, 1/2}};
Locator3D[pp, net4]]
Из сказанного выше следует, что каждая кратчайшая сеть является деревом с терминалами степени не выше 3 и дополнительными вершинами степени 3. Отсюда вытекает, что если n - число терминалов, то дополнительных вершин может быть не больше n - 2 (проверьте). Тем самым имеется конечное, хотя и экспоненциально растущее с ростом n, число комбинаторных структур кратчайших сетей. Доказано, что проблема Штейнера на евклидовой плоскости является NP -трудной, т. е. скорее всего не существует полиномиального по n алгоритма построения кратчайшей сети.
Тем не менее в последнее время разработаны достаточно быстрые алгоритмы, позволяющие строить кратчайшие сети для сотен точек. Приведем визуализацию одного свойства решения задачи Ферма, лежащего в основе всех точных алгоритмов.
Если на сторонах треугольника построить правильные треугольники, пересекающие исходный только по его сторонам, то три окружности (изображенные красным цветом), описанные вокруг построенных треугольников, пересекутся в одной точке. В той же точке пересекутся и три отрезка (изображенные синим цветом), каждый из которых соединяет добавленную вершину построенного правильного треугольника с противоположной ей вершиной исходного.
Если в треугольнике, построенном на терминалах, все углы не превосходят $$120^0$$, то общая точка пересечения красных окружностей и синих отрезков совпадает с решением задачи Ферма. Если же некоторый угол больше или равен $$120^0$$, то решение задачи Ферма - вершина этого угла:
In [99]:=
Manipulate[
Module [ {pc, рр, i , sign, pt3 = { } , tri = { } , seg = { } ,
с, r, circ = { } , dist, vec} ,
$$\begin{matrix}
dist[v_{-}, w_{-}] : = \sqrt{(v - w) . (v - w)} ;
\end{matrix}
$$vec[v_] := {Re[v],Im[v]};
pp = p ;
For i = 1, i <= 3, i++,
pc = Complex @@ # /@ pp ;
sign = Sign[Det[{pp [[3]] -pp[[1]], pp[[2]] -PP[[1]] } ] ] ;
If[sign ≠ 0,
pt3=pc[[1]]e-sing i π/3 + pc[[2]] esing I π/3;
с = Mean [{pp [[1]], pp[[2]], vec@pt3}];
r = dist[c, pp[[1]]] ;
tri = tri ≈ Join ≈ {{pp[[1]] , pp[[2]] , vec@pt3, pp[[1]]}};
seg = seg ≈ Join ≈ { {vec@pt3, рр[[3]] } } ;
circ = circ ≈ Join ≈{ {с, r}};
];
pp = RotateLeft[pp];
] ,
Graphics [ { {Dashed} ≈ Join ≈ (Line /@ tri) } ≈ Join ≈ {Blue} ≈
Join ≈ (Line /@ seg) ≈ Join ≈ {Red} ≈ Join ≈
(Circle @@ # /@ circ) , PlotRange -> {{-2, 2}, {-2, 2}},
AspectRatio -> Automatic]
] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Если заменить
Поэкспериментируйте с примером, приведенным ниже, и постарайтесь сформулировать правило, описывающее направление отрезков.
In[100] :=
Manipulate[Module[{x, y, s, distManhat},
distManhat[v_, w_] : = Plus @@ Abs@ (v - w) ;
s =
{x, y} /.
Last@
Quiet @ FindMinimum [Plus @@ (distManhat [ {x, y} , #] /@p) ,
{{x, First@Mean[p]} , {y, Last@Mean[p]}} ,
Method -> "PrincipalAxis"];
Graphics [Line [{s, #}] /@p, PlotRange -> { {-2 , 2}, {-2, 2}},
AspectRatio -> Automatic] ] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}
]
Ниже приведена реализация кратчайшей сети на манхеттенской плоскости в случае четырех терминалов. Обратите внимание на скачкообразное изменение кратчайшей сети при смещении терминалов. Эта особенность поведения сети объясняется неоднозначностью решения, в отличие от евклидова случая.
In [101] :=
Manipulate[
Module [{gl, g2 , g3, xl, yl, x2, y2 , min, res, resl, gr,
sub, v, e, distManhat, st, MyShowGraph} ,
distManhat[v_, w_] : = Plus @@ Abs@ (v - w) ;
st[g_, ls_] : =
Quiet@Module [ {w, ее, len} , w=Vertices[g];
ее = Edges [g] ; len = Plus @@ (distManhat @@vv[[#]] /@ee) ;
FindMinimum [len, {#, RandomReal [ ] } /@ Flatten [w[[ls]] ] ,
Method -> "Newton"] ≈ Join ≈ {g}] ;
MyShowGraph[g_, opts : OptionsPattern[Graphics]] : =
Module [ {vv, ее} , vv = Vertices [g] ; ее = Edges [g] ;
Graphics [Line [vv[[#]] ] /@ ее, opts] ] ;
gl = Graph[{{{l, 5}}, {{2, 5}}, {{5, 6}}, {{6, 3}},
{{6, 4}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g2 = Graph[{{{l, 5}}, {{3, 5}}, {{5, 6}}, {{6, 2}},
{{6, 4}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g3 = Graph[{{{l, 5}}, {{4, 5}}, {{5, 6}}, {{6, 3}},
{{6, 2}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g= {gl, g2, g3}; res = st[#, {5, 6}] /@g; min = Min[#|[l]] /@res] ;
resl = Select [res, #[[1]] == min ] // First;
gr = resl // Last;
sub = resl [[2]] ;
v = Vertices[gr] /. sub;
e = Edges [gr] ;
MyShowGraph[AddEdges[AddVertices[EmptyGraph[0], v] , e] ,
PlotRange -> {{-2, 2}, {-2, 2}}]
],
{{p, {{-1, 1}, {-1, -1}, {1, -1}, {1, 1}}}, Locator},
Initialization : -> (
Needs["Combinatorica""];
)]
Отметим, что единичная окружность на манхеттенской плоскости является квадратом, диагонали которого лежат на координатных осях. Обобщением манхеттенской метрики являются так называемые $$\lambda$$ -нормы, для которых единичная окружность - правильный $$2 \lambda$$ -угольник. Ниже приводится визуализация кратчайших сетей на $$\lambda$$ -нормированной плоскости в случае трех терминалов. При $$\lambda > 2$$ вновь отмечается скачкообразное поведение сетей при cмещении терминальных точек, что опять же объясняется неоднозначностью решения.
In[102] :=
Manipulate [
Module {x, y, s, lin, vec, nrf norm, cr, len, res, gsol, distNorm} ,
vec[v_] :={Re[v], Im[v]};
nr = vec@# /@ Table [еI π/2(k+1/2) , {к, 0, λ - 1);
norm [v_] :=(Max@@(Abc[@.v]/@nr)/(nr[[1]].{1,0});
distNorm [v_, w_] : = norm [v - w] ;
cr = ParametricPlot[({Cos[ϕ],Sin[ϕ]})/(norm[{Cos[ϕ], Sin[ϕ]}]),{ϕ,0,2π},}
PlotStyle -> {Red}];
len = Plus @@ (distNorm[{x, y} , #] /@ p) ;
res = Quiet@FindMinimum[len, {{x, RandomReal [ ] } , {y, RandomReal [ ] }} ,
Method -> "Newton"];
s = {x, y} /. Last@res;
Show[{Graphics[Line[{s, #} ] /@ p, PlotRange -> { {-2 , 2} , {-2,2}},
AspectRatio -> Automatic] , cr}]
] , {{λ, 3}, Rest@Range[20] }, {{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Определение 7.1.1. Графом называется пара G = (V,E) , где V - некоторое конечное множество, элементы которого называются вершинами, а E - семейство неупорядоченных пар (двухэлементных подмножеств) множества V, называемых ребрами. Если пара вершин v и w составляет ребро e = vw, то говорят, что эти вершины смежные или соседние. Также в этом случае говорят, что ребро e и вершина v инцидентны. Наконец, ребра, пересекающиеся по вершине, также называют смежными или соседними.
Замечание 7.1.1. Графы, которые мы только что определили, часто называют простыми. Аналогично определяются ориентированные графы (ребра - упорядоченные пары вершин) и мультиграфы (допускаются петли и кратные, т. е. соединяющие одни и те же вершины, ребра).
Граф G = (V,E) называется взвешенным, если на множестве его ребер задана весовая функция $$\omega : E \to R$$, которая обычно предполагается неотрицательной.
Для продуктивной работы с графами часто требуется визуализировать граф наиболее наглядным образом. Особенно эта проблема важна в случае больших графов. В пакете Mathematica имеется ряд встроенных функций рисования графов на плоскости или в трехмерном пространстве, при котором расположение вершин и форма ребер вычисляется так, чтобы оптимизировать тот или иной "эстетический" функционал.
Перечислим основные функции, используемые в пакете Mathematica для изображения графов, и приведем примеры их использования. Стандартная функция $$GraphPlot[\{v_{i1} \to v_{j1}, v_{i2} \to v_{j2}, \dota \}]$$ строит изображение мультиграфа, при котором вершина $$v_{ik}$$ соединяется ребром с вершиной $$v_{jk}$$:
In[1]:= GraphPlot [{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
При наведении курсора мыши на вершины графа возникают номера этих вершин. Заметьте, что пары {1, 2} встречаются три раза, - это изображено ребром кратности три. Кроме того, имеются петли, заданные двумя парами (4,4) и одной парой (3,3).
Вообще говоря, такое представление естественно для ориентированного графа, хотя приведенное выше изображение игнорировало этот факт. Визуализацию направления ребер можно включить следующей опцией:
In[2] := GraphPlot [{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
DirectedEdges -> True]
Вот еще два формата команды GraphPlot:
$$GraphPlot[\{\{ v_{i1} \to v_{jl}, lbl_1}, \dots \}]$$ приписывает ребру $$v_{ik} \to v_{jk}$$ метку $$lbl_k$$:
In[3]:= GraphPlot[{1 -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
{3 -> 1, "метка"}, 3 -> 2, 4 -> 1, 4 -> 2,
4 -> 4, 4 -> 4}]
GraphPlot[m] строит граф по матрице вершинной смежности, в которой на (i,j)-м месте стоит кратность ребра, идущего из вершины с номером i в вершину с номером j (если ребра нет, то кратность равна нулю). Заметим, что теперь для визуализации петель и кратных ребер нужно специально включать соответствующие опции SelfLoopStyle и MultiedgeStyle, которые по умолчанию выключены.
In[4]:= GraphPlot [{{0, 2, 0, 0}, {1, 0, 0, 0}, {1, 1, 1, 0},
{1, 1, 0, 2}}, DirectedEdges -> True,
SelfLoopStyle -> True, MultiedgeStyle -> True]
In[5]:= GraphPlot [{{0, 2, 0, 0}, {1, 0, 0, 0},
{1, 1, 1, 0}, {1, 1, 0, 2}}]
У команды GraphPlot[m] имеется много опций, с которыми можно ознакомиться, нажав кнопку MORE INFORMATION из Help для GraphPlot.
Команда GraphPlot3D имеет такой же формат, как и GraphPlot, однако изображает графы в трехмерном пространстве.
In[6] :=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
In[7]:=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4}]
А вот пример более симпатичного изображения графа. Здесь опция EdgeRenderingFunction определяет функцию прорисовки ребра (в примере рисуется трубка Tube, ось которой задается последовательными точками ребра, возвращаемыми GraphPlot3D в первый аргумент #1 этой функции, 0.015 - радиус трубки), опция VertexRenderingFunction - функцию прорисовки вершин (они изображаются сферами):
In[8]:=GraphPlot3D[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2,
4 -> 4, 4 -> 4}, SelfLoopStyle -> True,
MultiedgeStyle -> True,
EdgeRenderingFunction -> (Tube[#2, 0.015] ) ,
VertexRenderingFunction -> ({ColorData["Atoms"]
[RandomInteger[{l, 117}]], Sphere[#2, .08]} ) ,
PlotStyle -> Directive[Specularity[White, 20] ] ,
Boxed -> False]
Функция LayeredGraphPlot относится к так называемому иерархическому рисованию и изображает ориентированный граф, располагая вершины на уровнях так, чтобы доминантные вершины (те, в которые входит как можно меньше стрелочек) оказались наверху, а стрелочки были направлены преимущественно вниз. Ниже приведена программа, демонстрирующая, как меняется вид графа при изменении направления ровно одного ребра.
In[9] :=
DynamicModule[{v, w, edge},
v ={1 -> 2, 3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4}; vv= v;
Manipulate[
If [ls ≠ "None", edge = List @@ ToExpression[ls] ;
vv = v / . Rule @@ edge -> Rule @@ (RotateLef t [edge]) ] ;
Row[{LayeredGraphPlot[v, VertexLabeling -> True,
EdgeRenderingFunction ->
(If[(ls ≠ "None") (# == edge) , {Red, Arrowheads[{{Automatic, 0.5}}] ,
Arrow[#2]}, {Blue, Arrowheads[{{Automatic, 0.5}}], Arrow[#1]}] ) ,
ImageSize -> 250] ,
LayeredGraphPlot[vv, VertexLabeling -> True, ImageSize -> 250,
EdgeRenderingFunction ->
(If [(ls ≠ "None") (#2 == RotateLeft[edge]) ,
{Red, Arrowheads [{ {Automatic , 0.5}}], Arrow[#l]},
{Blue, Arrowheads[{{Automatic, 0.5}}], Arrow[#1]}] )]}," " ] ,
{{ls, "None", "ребро"}, { "None" } ≈ Join ≈ (ToString/@ v) } ] ,
UnsavedVariables -> {vv, edge}]
Отметим, что у функции LayeredGraphPlot имеется еще один формат, а именно, LayeredGraphPlot[g,pos] , позволяющий задавать, с какой стороны располагать доминантные вершины. Возможные значения для pos -это Right, Left, Top и Bottom:
In[10] := Manipulate [
LayeredGraphPlot[
{1 -> 2, 1 -> 2, 3 -> 1, 3 -> 2, 3 -> 4, 4 -> 1,
4 -> 2, 4 -> 4},
pos,
VertexLabeling -> True] ,
{
{pos, "Top", "Положение доминантной вершины"},
{Top, Bottom, Left, Right}
}
]
Еще одна иерархическая функция изображения графов - это TreePlot. Несмотря на название, она применима не только к деревьям, но и к графам общего вида (в качестве деревьев у графов берутся LayeredGraphPlot, однако она имеет дополнительный формат TreePlot[g,pos,v_k] , в котором $$v_k$$ обозначает вершину, которую нужно выбрать в качестве корня. Кроме того, pos может принимать еще и значение Center:
In[11] :=Manipulate[TreePlot[{l -< 2, 1 -< 2, 3 -< 1,
3 -> 2, 3 -> 4, 4 -> 1, 4 -> 2, 4 -> 4},
pos, root, VertexLabeling -> True,
DirectedEdges -> True],
{{pos, Top, "Положение доминантной вершины"},
{Top, Bottom, Left, Right, Center}},
{{root, 1, "Доминантная вершина"}, {1, 2, 3, 4}},
ControlPlacement -> Top]
У всех перечисленных выше функций рисования графов имеется полезная для решения геометрических задач опция VertexCoordinateRules, позволяющая явно указывать координаты вершин графа. Координаты можно задавать или в виде списка, или явно указывать, какой вершине какие координаты приписать, т. е. $$i \to \{х_i, y_i, \dots\}$$. Также вместо некоторых координат может стоять Automatic:
In[12] :=
Manipulate[
graphPlot[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3, 3 -> 1,
3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
VertexCoordinateRules -> p, PlotRange -> { {-1, 2}, {-1, 2}},
AspectRatio -> Automatic, DirectedEdges -> True] ,
{{P, {{0, 0}, {1, 0}, {0, 1}, {1, 1}}}, Locator},
{graphPlot, {GraphPlot, LayeredGraphPlot, TreePlot}}]
In[13] : =
DynamicModule[ {p0 , pp, plnit},
p0 = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};
pInit = p0|[Drop [Range [4] , {1}]]];
Manipulate [plnit = pO[[Drop [Range [4] , {automatic} ] ]] ;
pp = Maplndexed[First[#2] -> #1 ,
Insert[p, {Automatic, Automatic}, automatic]];
Quiet@graphPlot[{l -> 2, 1 -> 2, 2 -> 1, 3 -> 3,
3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 4, 4 -> 4},
VertexCoordinateRules -> pp, PlotRange -> {{-1, 2}, {-1, 2}},
AspectRatio -> Automatic, DirectedEdges -> True] ,
{{p, plnit}, Locator},
{graphPlot, {GraphPlot, LayeredGraphPlot, TreePlot}},
{{automatic, 1, "Вершина, позиционируемая автоматически"},
{1, 2, 3, 4}}], UnsavedVariables -> {pp, plnit}
]
В пакете Mathematica предусмотрено две группы средств для работы с графами. Одна предназначена для создания, хранения и преобразования информации в виде графов. Другая, с которой мы познакомились в предыдущем разделе, - для визуализации уже имеющихся графов.
Описываемые здесь процедуры являются частью пакета Combinatorica, поэтому перед началом работы с ними следует выполнить команду, загружающую этот пакет:
In[14] := Needs [ "Combinatorica' " ]
Граф в пакете Combinatorica задается командой Graph[<, где каждое ребро (т. е. элемент списка ребер) имеет вид {{<номер вершины>, <номер вершины >},<опции ребра>} , каждая вершина (т. е. элемент списка вершин) имеет вид {{координаты вершины на плоскости\},<опции>} , и, наконец, в списке опций стоят общие команды для всех вершин, всех ребер и графа в целом. Обратим внимание на двойные фигурные скобки, которые объясняются возможным наличием опций.
В пакете Combinatorica также имеются встроенные функции для визуализации графов, такие как ShowGraph[< граф >] или ShowGraphArray.
In[15]:=ShowGraph[Graph[{{{l, 2}}, {{2, 3},
EdgeColor -> Red}, {{3, 1}}}, {{{-1, 0}},
{{1, 1}, VertexColor -> Blue,
VertexStyle -> Disk[Large]}, {{1, 0}}}]]
Более сложный пример. В нем положение вершин задано случайно, а количество и соседство можно регулировать. Кроме того, справа тот же граф перерисован с установкой общих опций, регулирующих вид вершин и ребер. Заметим, что внешние опции, если установлены, перекрывают соответствующие опции, установленные для конкретных вершин (ребер):
In[16] : =
Manipulate [Module [{w, ее, gg} ,
If [k > n- 1, k = n- 1] ;
If [n ≠ Length [w] ,
vv = Map[{#, VertexNumber -> True} , Table [ {Random [] , Random []} , {n}]]];
ее =
Table [{{i, Mod[i + k, n] + 1} , If [Mod [i, 2] = =0, EdgeColor -> Red,
EdgeColor -> Green] } , {i, 1, n} ]; g = Graph [ее, vv] ;
gg = Graph [ее, vv, {EdgeStyle -> edgSt, VertexStyle -> vrSt}] ;
GraphicsRow[{ShowGraph[g], ShowGraph[gg]}]], {{n, 4}, 2, 27, 1},
{{k, 1}, 0, n-1, 1}, {{edgSt, {Green, Red}, "Вид ребра"},
{{Blue} -> "Синий", {Dashed} -> "Пунктир", {Blue, Dashed} -> "Синий-Пунктир" } } ,
{{vrSt, {Disk[Normal]}, "Размер вершины"},
{{Disk[Normal] } -> "Нормальный" , {Disk[Small] } -> "Мелкий" ,
{Disk[Medium] } -> "Средний", {Disk[Large] } -* "Крупный"}},
Initialization: -> (Needs ["Combinatorica" "] )]
Граф, заданный в пакете Combinatorica, можно визуализировать с помощью GraphPlot или GraphPlot3D. Картинка будет куда нагляднее, однако часть информации, такая как цвета ребер и пр., при этом теряется:
In[17] :=Dynamic[GraphPlot3D[g] ]
Отметим, что описанные способы задания графов громоздки и не всегда удобны. Имеется ряд возможностей конструировать графы из более привычных наборов данных, служащих для описания графов. Так можно породить неориентированный граф из списка неупорядоченных пар вершин FromUnorderedPairs[<список>], и ориентированный граф - из списка упорядоченных пар вершин FromOrderedPairs[<список>]. Также граф можно породить из матрицы вершинной смежности FromAdjacencyMatrix[m] и из списков вершинной смежности FromAdjacencyLists[l] :
In [18]:= listOfUnPairs = {{1, 2}, {1, 3}, {1, 4},
{1, 5}, {1, 6}, {2, 3}, {3, 4}, {4, 5},
{5, 6}, {6, 2}};
vc= {{0, 0}} ≈ Join ≈
Map[{Cos[ ((2 π)/5) #] , Sin[((2 π)/5 #]} , Range [5]] ;
g1= FromUnorderedPairs[listOfUnPairs] ;
g11 = FromUnorderedPairs[listOfUnPairs, vc] ;
ShowGraphArray[{gl, gl 1} ]
Отметим, что для такого задания графа координаты вершин, вообще говоря, не нужны. Mathematica сама выберет в качестве них по умолчанию равномерный набор точек на окружности. Последнее, впрочем, не всегда хорошо отражает суть дела. Если нам не нравится выбор Mathematica, то имеется возможность задать точки самим, для чего используется второй необязательный аргумент.
Как мы уже говорили, другой способ получения наглядной картинки - воспользоваться GraphPlot. Использование этой команды, однако, таит в себе некоторые неожиданности. Если, например, включить опции, показывающие направления ребер и их кратность, то мы увидим, что наш неориентированный простой граф воспринимается на самом деле как ориентированный:
In [23] :=GraphicsRow[ {GraphPlot [g1] ,
GraphPlot[g1, DirectedEdges -> True,
MultiedgeStyle -> True] } ]
Из тех же данных можно породить ориентированный граф командой FromOrderedPairs[<список>]:
In[24]=g2 = FromOrderedPairs [listOfUnPairs] ;
g21 = FromOrderedPairs[listOfUnPairs, vc] ;
ShowGraphArray[{g2, g21} ]
Теперь и GraphPlot даст нам тот ориентированный граф, который мы задавали на самом деле:
In [27] := GraphPlot [g2 , DirectedEdges -> True,
MultiedgeStyle -> True]
При помощи команды FromAdjacencyMatrix[m] можно породить как неориентированный граф, так и ориентированный (при этом обязательно выставить опцию Type \to . Directed, иначе получится неориентированный граф, заданный верхним треугольником матрицы смежности). Кроме того, имеется возможность задать граф с
g3 = FromAdjacencyMatrix [m1] ; g31 = FromAdjacencyMatrix [ml, vc] ;
g32 = FromAdjacencyMatrix [m2, vc, Type -> Directed] ;
g33 = FromAdjacencyMatrix [m3 , vc] ;
ShowGraphArray [ {g3 , g31, g32 , gЗЗ}]
In [32] :=
GraphicsRow[ GraphPlot[
#, DirectedEdges -> True, MultiedgeStyle -> True] /@
{gЗ, g32, gЗЗ}]
Наконец, можно задать взвешенный граф, т. е. приписать ребрам графа некоторые числа, называемые весами. Установка опции EdgeWeight порождает взвешенный граф, в чем можно убедиться, выведя Edges. Теперь элементы матрицы интерпретируются как веса. Для отсутствующих ребер следует в этом случае ставить $$\infty$$ (а не нуль).
g34 = FromAdjacencyMatrix[m4, vc, EdgeWeight] ;
el = Edges[g34, EdgeWeight]
Out[35] =
{{{1, 2}, 3}, {{1, 3}, 1}, {{1, 4}, 4}, {{1, 5}, 1}, {{1, 6}, 1},
{{2, 3}, 1}, {{2, 6}, 1}, {{3, 4}, 6}, {{4, 5}, 15}, {{5, 6}, 1}}
Чтобы визуализировать веса ребер взвешенного графа, можно установить значения меток ребер равными соответствующим весам (это делается с помощью команды SetEdgeLabels[<граф>,<список меток>]) и выставить опцию {EdgeLabel \to True}. Обратите внимание: команда SetEdgeLabels не меняет метки исходного графа, а создает новый граф:
In [36] :=g35 = SetEdgeLabels [g34, #[[2]] /@ el] ;
ShowGraphArray[{g35, д34}, {EdgeLabel -> True}]
Кроме того, можно снова воспользоваться GraphPlot, применяя функцию EdgeRenderingFunction для визуализации значений весов ребер. Отметим, что GraphPlot воспринимает графы старого формата так, что каждое ребро учетверяется: две копии ориентированы в одну сторону, а две другие - в другую. Ниже предлагается реализация функции прорисовки ребра, основанная на том, что функция GetEdgeWeights не различает направления ребер:
In[38] :=
GraphPlot [g34 , EdgeRenderingFunction ->
( {Line [#1] , Inset [Style [" " <> ToString @@ GetEdgeWeights [g34 , {#2}] <>" ",
Red, Large] , Mean[#1] , Automatic, Automatic, #1[[1]] - #2[[2]],
Background -> White] } ) ]
Наконец, для задания графов можно воспользоваться списками смежности и командой FromAdjacencyLists. Отметим, что в этих списках также допускается указывать веса ребер. i -м месте стоит список номеров вершин, смежных с i -й вершиной. Если надо указать веса ребер, то в i -м списке вместо номера j ставится пара вида $$\{j, \omega\}$$, где $$\omega$$ - вес ребра ij:
In [39] :=
(*Обычные списки смежности *)
11= {{2, 3, 4, 5, 6}, {1, 3, 6}, {1, 2, 4}, {1, 3, 5} , {1, 4, 6}, {1, 2, 5}};
vc = {{0, 0}} ≈ Join ≈ Map [{cos[((2 π)/5) #] , Sin[((2 π)/5)#]} , Range [5] ] ;
g4 = FromAdjacencyLists [11] ; g41 = FromAdjacencyLists [11, vc] ;
(*Списки смежности с весами *)
lw= {{{2, 1}, {3, 3}, {4, 2}, {5, 1}, {6, 2}}, {{1, 1}, {3, 2}, {6, 3}},
{{1, 3}, {2, 2}, {4, 5}}, {{1, 2}, {3, 5}, {5, 1}}, {{1, 1}, {4, 1}, {6, 6}},
{{1, 2}, {2, 3}, {5, 6}}};
g42 = FromAdjacencyLists[lw, EdgeWeight];
(*Устанавливаем метки ребер равными их весам *)
g43=SetEdgeLabels[g42, #[[2]] /@ Edges[g42, EdgeWeight]];
ShowGraphArray [ {g4 , g41, g43} , VertexNumber -> True , EdgeLabelColor ->Red]
Если граф уже есть, то можно получить из него набор соответствующих (упорядоченных) пар, матрицу смежности, ToUnorderedPairs, ToOrderedPairs, ToAdjacencyMatrix и ToAdjacencyLists, соответственно. При этом надо внимательно следить за опциями. Например, отсутствие опции EdgeWeight приводит к потере информации о весах ребер:
In [46] : =
11= {{{2, 0.1}, {2, π //N}, {3, .13}},
{{2, √3 // N}, {3, Log[2] //N}}, {}};
(*ll={{{2,10},{2, π //N},{3,.13}},{{2, √3 //N},{3,Log[2]//N}},
{}};*)
gr = FromAdjacencyLists[11, EdgeWeight, Type -> Directed];
Row[{ShowGraph[gr, EdgeLabel -> GetEdgeWeights[gr],
EdgeLabelColor -> Red,
EdgeLabelPosition -> {{ .0, .05}, {.1, -.05}, {.05, .05}, \
{.05, .05}, {.05, .05}}],
ToAdjacencyMatrix[gr, EdgeWeight] // MatrixForm,
ToAdjacencyMatrix[gr] //MatrixForm}, Spacer[64]]
Обратите внимание, что при переходе к матрице смежности веса кратных ребер теряются, несмотря на опции (из них берется максимальный). Ориентируемость - сохраняется. Отметим также, что визуализировать веса кратных ребер с помощью меток не тривиально, так как, во-первых, некорректно работает функция SetEdgeLabels и положения меток кратных ребер по умолчанию совпадают:
In [49]:=11= {{{2, .1}, {2, π //N}, {3, .13}},
{{2, √3//N}, {3, Log[2] //N}}, {}};
gr = FromAdjacencyLists[11, EdgeWeight, Type -> Directed];
wgh = GetEdgeWeights[gr]
grr = SetEdgeLabels[gr, wgh] ;
Edges[grr. All]
Out[51] = {0.l, 3.14159, 0.13, 1.73205, 0.693147}
Out[53] = {{{1, 2}, EdgeWeight -> 0 .1, EdgeLabel -> 0.1},
{{1, 2}, EdgeWeight -> 3.14159, EdgeLabel -> 0 .1},
{{1, 3}, EdgeWeight -> 0.13, EdgeLabel -> 0 .13},
{{2, 2}, EdgeWeight -> 1.73205, EdgeLabel -> 1.73205},
{{2, 3}, EdgeWeight -> 0. 693147, EdgeLabel -> 0 . 693147 }}
Во-вторых, некорректно работает функция SetEdgeWeights:
In [54]:=ll= {{2, 2, 3}, {2, 3}, {}} ;
gr = FromAdjacencyLists[11, Type -> Directed];
grr = SetEdgeWeights[gr, { . 1, . 2 , . 3 , . 4 , .5}] ;
Edges[grr, All]
Out[57] = {{{1, 2}, EdgeWeight -> 0.1},
{{1, 2}, EdgeWeight -> 0.1}, {{1, 3}, EdgeWeight -> 0 . 3},
{{2, 2}, EdgeWeight -> 0 . 4 }, {{2, 3}, EdgeWeight -> 0.5}}
Имеется много команд, позволяющих менять уже заданный граф. Вот лишь некоторые из них: AddEdge, AddEdges, AddVertex, AddVertices, DeleteEdge, DeleteEdges, MakeDirected, MakeUndirected, DeleteVertex, ReverseEdges, RemoveMultipleEdges и т. д. (полный список команд содержится в Help, в разделе Constructing Graphs ).
In[58] :=ShowGraphArray[{gll, AddEdges [gll, {{2, 5}, {2, 4}}],
g21, AddEdges [g21, {{2, 5}, {2, 4}}]}]
In [59]:=
gg = DeleteVertex [gll, 1] ; ggl = AddVertex [gg] ;
gg2 = AddEdges[AddVertex[gg] , {{6, 1}, {6, 2}, {6, 3}, {6, 4}}];
GraphicsRow [Framed /@ ShowGraph /@ {gg, ggl, gg2} ]
В этом же разделе Constructing Graphs описаны некоторые операции над графами, способы порождать случайные графы и деревья (см. определение ниже).
Отметим, что, по-видимому, авторы пакета Combinatorica предполагали, вместо непосредственного задания графов, использовать именно построение их из уже имеющихся. Поэтому операции над графами хорошо разработаны и, кроме того, имеется как богатая коллекция встроенных графов, см. Built-in Graphs, так и огромная база GraphData:
In [61] := Manipulate [If [SameQ [h, RandomGraph] , ShowGraph [h [n, 0.5]] ,
ShowGraph[h[n]]],
{{h, EmptyGraph} , {EmptyGraph -> "Пустой", Wheel -> "Колесо",
CompleteGraph -> "Полный" , Hypercube -> "Гиперкуб" ,
RandomGraph -* "Случайный"} , Setter} ,
{{n, 3}, Drop[Range[7] , 2] , PopupMenu} ]
Маршрутом $$\gamma$$ в графе G = (V, E) называется такая последовательность вида $$v_{1e_1v2} \dots v_ke_kv_{k+1}$$, где $$v_i \in V$$ и $$e_i \in E$$, что для каждого $$i,1 < i < k$$, ребро $$e_i$$ соединяет вершину $$v_i$$ с вершиной $$v_{i+1}$$. При этом удобно говорить, что маршрут $$\gamma$$ соединяет вершины $$v_1$$ и $$v_{k+1}$$, и называть такой маршрут $$(v_1,v_{k+1})$$ - маршрутом. Маршрут называется путем, если все его элементы, кроме, быть может, $$v_1$$ и $$v_{k+1}$$, различны. Путь, в котором $$v_1 = v_{k+1}$$, называется циклом Граф называется связным, если для каждых двух его различных вершин $$u$$ и $$v$$ существует ( $$u, v$$ )-маршрут.
Пусть $$G = (V, E) $$ - ориентированный граф. Говорят, что вершина $$v \in V$$ достижима из $$u \in V$$, если существует некоторый (u, v ) -маршрут.
Пусть G = (V, E) - взвешенный граф (ориентированный или нет) весовая функция. Весом маршрута называется сумма весов всех входящих в него ребер. Предположим, что вершина $$v \in V$$ достижима из $$u \in V$$, и рассмотрим множество $$?(u, v) $$ всех (u, v ) -маршрутов в G. Маршрут $$\gamma \in ?(u,v) $$ называется кратчайшим путем, если его вес не превосходит веса любого другого маршрута из ?(u,v) . Оказывается, если весовая функция $$\omega$$ неотрицательна, то существуют полиномиальные (порядка $$n^3$$, где n - количество вершин) алгоритмы поиска кратчайшего пути. В Mathematica реализован известные алгоритмы Dijkstra (для положительных весов), а также BellmanFord (для любых весов). Имеется несколько возможностей использования этих алгоритмов. Чтобы проиллюстрировать это, мы воспользуемся сначала генера
тором случайных графов и случайных весов ребер:
In [62] : = g : = SetEdgeWeights [ RandomGraph [ 17 , . 2 , Type -> Directed] ] ;
SG[g_] := Module [{gg, el},
gg = g;
el = Edges[gg, EdgeWeight] ;
ShowGraph[SetEdgeLabels[gg, #[[2]] /@el] ,
EdgeLabel -> True, EdgeLabelColor -> Green,
VertexLabel -> True, VertexLabelColor -> Red]
];
In [64] :=gcur = g;
SG[gcur]
Отметим, что такая визуализация не очень наглядна. Ниже мы предложим другие картинки, а пока прокомментируем, как работают нужные нам функции.
Команда ShortestPath[<граф>,<начальная вершина>, <конечная вершина>] выдает кратчайший путь в виде списка последовательных вершин:
In [66] :=sp = ShortestPath[gcur, 1, #] /@ Drop [Range [17] , 1]
Out[66] =
{{1, 13, 2}, {1, 13, 2, 3}, {1, 9, 4}, {1, 9, 4, 5},
{1, 9, 4, 6}, {1, 7}, {1, 13, 8}, {1, 9}, {1, 13, 8, 10},
{1, 9, 4, 6, 15, 11}, {1, 9, 12}, {1, 13}, {1, 13, 2, 3, 14},
{1, 9, 4, 6, 15}, {1, 13, 8, 10, 16}, {1, 9, 4, 6, 15, 17}}
Команда Dijkstra[<взвешенный граф>,<вершина>] ищет кратчайшие пути из заданной вершины во все остальные и выдает дерево, составленное из этих кратчайших путей, а также список весов этих путей. Если вершина недостижима, вес пути равен $$\infty$$. Дерево задано списком, на i -м месте которого стоит номер предшественника i -й вершины на ее кратчайшем пути:
In[67] :=dres = Dijkstra [gcur, 1]
Out[67] =
{{1, 13, 2, 9, 4, 4, 1, 13, 1, 8, 15, 9, 1, 3, 6, 10, 15},
{0, 1.11861, 1.2893, 0.958737, 1.17908, 1.34366,
0.391181, 1.08315, 0.811084, 1.27326, 1.6335,
1.38924, 0.692262, 1.6398, 1.34464, 1.48651, 1.41455}}
In [68]:= Column [
{TreePlot[gcur, Center, 1, VertexLabeling -> True,
DirectedEdges -> True,
PlotStyle -> {Arrowheads[{{.02, 0.5}}]}],
LayeredGraphPlot[gcur, VertexLabeling -> True,
DirectedEdges -> True] } , Spacer [4] ]
Эта функция восстанавливает пути, найденные процедурой Dijkstra:
In [69] : = path[end_, start_, dij_] : =
Module[{ic, p, spt} , If[dij[[2, end]] == ∞ , {start},
spt = dij[[l]]; ic = end; p = {end} ;
While [spt[[ic]] \ne start, ic = spt[[ic]]; p= {ic} ≈ Join ≈ p] ;
{start} ≈ Join ≈ p]] ;
In [70] :=path[#, 1, dres] /@ Drop [Range [17] , 1]
Out[70] =
{{1, 13, 2}, {1, 13, 2, 3}, {1, 9, 4}, {1, 9, 4, 5}, {1, 9, 4, 6}, {1, 7},
{1, 13, 8}, {1, 9}, {1, 13, 8, 10}, {1, 9, 4, 6, 15, 11}, {1, 9, 12}, {1, 13},
{1, 13, 2, 3, 14}, {1, 9, 4, 6, 15}, {1, 13, 8, 10, 16}, {1, 9, 4, 6, 15, 17}}
Если забыть про ориентацию ребер, то кратчайшие пути могут измениться, так как возникают дополнительные возможности:
In [71]:=
DynamicModule [ {n = 11, gres = gcur} ,
(*gcur=SetEdgeWeights [ RandomGraph [ 11, . 2 , Type -> Directed] ] ; *)
Manipulate [If [dir, gres = gcur, gres = MakeUndirected [gcur] ] ;
shortPShowL [gcur, ShortestPath [gres, i, j] , i, j , dir] ,
{{i, 1, "Начальная вершина"}, Range[V[gcur]], ControlType -> PopupMenu},
{{j, 2, "Терминальная вершина"}, Range[V[gcur]],
ControlType -> PopupMenu} ,
{{dir, True, "Ориентируемость"}, {True, False}},
SaveDef initions -> True] ,
Initialization : -> (Needs["Combinatorica' "] ;
edgeW[g_, e_] : = GetEdgeWeights [g, {e}][[l]],
shortPShowL[g_, p_, ii_, jj_r test_] : =
Module [{edg, 11, ends, e = 0.1},
edg = Table [Take [p, {i, i + 1}], {i, 1, Length [p] - 1}] ; ends = {ii, Jj} ;
11 = edg ≈ Join ≈ (RotateLeft[#, 1] /@edg) ;
If [Length [p] < 2,
Show[{Graphics[Text[Style["Путей НЕТ", Red, Bold, Large] , {0, 0}] ] ,
LayeredGraphPlot[g,
EdgeRenderingFunction ->
(If [test, {Black, Arrowheads[{{.02 , 0.5}}], Arrow[#1]},
{Black, Line[#l]}] ),
VertexRenderingFunction ->
({If[MemberQ[ends, #2] , Pink, White] , EdgeForm[Black] ,
Disk[#, .5] , Black, Text[#2, #1]} ) , ImageSize -> 600]
}],
LayeredGraphPlot [cr, EdgeRenderingFunction ->
(If[MemberQ[ll, #2], {Red}, {Orange, Opacity[0.5]}] ≈
Join ≈ If [test, {Arrowheads [{{ .02, 0.5}}], Arrow[#1]} ,
{Line [#1]}] ),
VertexRenderingFunction ->
({Which [MemberQ [ends, #2] , Pink, MemberQ[p, #2] , LightBlue,
True, White], EdgeForm[Black], Disk[#, .5], Black,
Text[#2, #1]} ) , ImageSize -> 600] ] ])]
Если ShortestPath. Для визуализации воспользуемся продвинутыми возможностями GraphPlot3D. Ребра изобразим в виде разноцветных цилиндров разной толщины. Толщина и цвет зависят от веса. Ребра кратчайшего пути выделены матовым красным. Номера концевых вершин пути - черные, промежуточных вершин - синие. Напомним, что, двигая мышкой при нажатой клавише Alt, можно приблизить/удалить объект, а при нажатой клавише Shift - сместить его в сторону:
In [72] :=
DynamicModule[{},
(*gcur=SetEdgeWeights[ RandomGraph[11, . 2,Type -> Directed]];*)
Manipulate[shortPathShow[gcur, ShortestPath[gcur, i, j], r] ,
{{i , 1} , Range[V[gcur]] , ControlType -> PopupMenu},
{{j 2}, Range[V[gcur]] , ControlType -> PopupMenu},
{{r, 0.1}, 0.01, 0.4}, SaveDefinitions -> True] ,
Initialization: -> (Needs [ "Combinatorica" ] ;
edgeWeight[g_, e_] : = GetEdgeWeights[g, {e}];
shortPathShow[g_ , p_ , r_ ] :=
Module[{edg, 11, ends, 6 = 0.1},
edg = Table [ Take [p, {i, i + 1}], {i, 1, Length[p] -1}] ;
ends = {pill, Pl-l]};
11 = edg≈ Join ≈ (RotateLef t [# , 1] /@ edg) ;
If[Length[p] < 2,
Show[
{Graphics3D[Text[Style["Нет пути!", Red, Bold, Large],
{0, 0, 0}]] ,
GraphPlot3D[g,
EdgeRenderingFunction ->
({Hue[edgeWeight[g, #2]] ,
Cylinder [#1, r edgeWeight [g, #2]]} ) ,
VertexRenderingFunction ->
({Yellow, Sphere [#1, r + 0.03],
Text[Style[#2, Green, Bold, Large],
#1+ {e , e, e}]} ), ImageSize -> 500,
Viewpoint -> {3.25, 0.57, 3.25}]
}],
GraphPlot3D[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2] , {Glow[Black] , Red},
{Lighter [Hue [edgeWeight [gr, #2]], .5]}] ≈ Join ≈
{Cylinder[#l, Max [r edgeWeight [g, #2], 0.01]]} ) ,
VertexRenderingFunction ->
({If [MemberQ[p, #2 , Red, Yellow] , Sphere [#1, r + 0.03] ,
Text[Style[#2, Which[MemberQ[ends, #2], Black,
MemberQ[p, #2] , Blue, True, Green], Bold, Large] ,
#1 + {e, e , e} ] } ) , Boxed -> False, ImageSize -> 500 ,
Viewpoint -> {3.25, 0.57, 3.25}]
]])]
В следующем варианте картинка двумерная, веса ребер снова проиллюстрированы их толщиной. Зато хорошо видны стрелки:
In [73] : =
DynamicModule[{n = 11},
Manipulate[shortPShow[gcur, ShortestPath[gcur, i, j],
if jf r] , {{i, 1} , Range [V [gcur]] ,
ControlType -> PopupMenu} ,
{{j, 2} , Range[V[gcur]], ControlType -> PopupMenu},
{{r, 0.003}, 0.003, .01}, SaveDefinitions -> True],
Initialization : -> (Needs [ "Combinatorica' " ] ;
edgeW[g_, e_] : = GetEdgeWeights [g, {e}][[l]];
shortPShow [g_, p_, H_, jj_t *_] : =
Module[{edg, 11, ends, 6 = 0.1},
edg = Table [Takefp, {i, i + 1}], {i, 1, Length [p] - 1}] ;
ends = {ii, jj) ;
11 = edg ≈ Join ≈ (RotateLef t [#, 1] /@ edg) ;
If[Length[p] < 2,
Show[
{Graphics[Text[Style["Путей НЕТ", Red, Bold, Large],
{0, 0}]],
GraphPlot[g,
EdgeRenderingFunction ->
({Black, Arrowheads[{{0.02, 0.5}}] ,
Arrow[#l]} ),
VertexRenderingFunction ->
({If[MemberQfends, #2] , Pink, White],
EdgeForm[Black] , Disk[#, .1] , Black,
Text [#2, #l } ) , ImageSize -> 500]
}],
GraphPlot[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2], {Blue},
{Orange, Opacity[0.5]}] ≈ Join ≈
{Thickness [r edgeW[g, #2]],
Arrowheads [{{3 r , 0.5}}] , Arrow [#l, .1]} ) ,
VertexRenderingFunction ->
( {Which [MemberQ [ends, #2] , Pink, MemberQ[p, #2],
LightBlue, True, White], EdgeForm[Black],
Opacity[0.7], Disk[#, .1] , Opacity[1] ,
Black, Text[#2, #l] } ) , ImageSize -> 500]
]])]
Связный граф без циклов называется деревом. Понятие
Подграфом H в графе $$G = (V_G, E_G) $$ называется такой граф $$H = (V_H, E_H) $$, что $$V_H \subset V_G$$ и $$E_H \subset E_G$$. Если граф G - взвешенный с весовой функцией $$\omega$$, то для каждого его подграфа H естественно определяется его вес, равный сумме весов всех ребер этого подграфа.
Подграф $$H \subset G$$ называется остовным, если $$V_H = V_G$$. В каждом связном графе, очевидно, имеется остовный подграф, являющийся деревом. Такие подграфы называются остовными деревьями. Количество разных
Остовное дерево наименьшего веса в связном взвешенном графе называется минимальным остовным деревом Несмотря на упомянутую оценку, имеются полиномиальные алгоритмы построения минимальных
Пусть G = (V,E) - связный взвешенный граф с весовой функцией $$\omega$$. Определим граф $$T_0 = (V, \varnothing) $$. На $$i$$ -м шаге, $$1 \le i \le n - 1$$, среди всех ребер, добавление которых к $$T_{n-1}$$ порождает ацикличный граф, выберем ребро наименьшего веса и добавим к $$T_{i-1}$$ получив тем самым $$T_i$$. Алгоритм заканчивает работу, построив граф $$T_{n-1}$$, который и является минимальным остовным деревом.
В пакете Combinatorica имеется команда MinimumSpanningTree[<граф>], возвращающая минимальное остовное дерево в формате Graph.
Снова нарисуем красивые картинки:
In[74] :=
DynamicModule[{gu, gcur, mst, n = 11},
gu = RandomGraph[n, . 6] ;
While [! ConnectedQ[gu], gu = RandomGraph[n, . 6] ] ;
gcur = SetEdgeWeights[gu];
mst = MinimumSpanningTree[gcur];
Manipulate[plot3DWGraph[gcur, Edges[mst], r,
{Glow[Red], Brown}], {r, 0.01, 0.2}],
Initialization : -> (Needs [ "Combinatorica" " ] ;
edgeWeight [ g_, e_] : = GetEdgeWeights [g, {e}];
plot3DWGraph[g_, 1_, r_, col_, op_:l] := Module[ {11} ,
11 = 1≈ Join ≈ (RotateLeft[#, 1] /@ 1) ;
GraphPlot3D[g,
EdgeRenderingFunction ->
(If[MemberQ[ll, #2] , col,
{Lighter[Hue[edgeWeight[g, #2]], .9],
Opacity[op]}]≈ Join ≈
{Cylinder[#2, Max [ r edgeWeight [ g, #2], 0.01]]} ) ,
VertexRenderingFunction ->
({Yellow, Sphere[#, r+ 0.03]} ) , Boxed -> False] ] ) ]
In[75] :=
DynamicModule[{gu, gcur, mst, n = 11},
gu = RandomGraph[n, . 6] ;
While[! ConnectedQfgu], gu = RandomGraph[n, . 6] ] ;
gcur = SetEdgeWeights[gu];
mst = MinimumSpanningTree[gcur] ;
Manipulate[plotWGraph[gcur, Edges[mst], r, Red, Orange],
{r, 0.01, 0.1}],
Initialization : -> (Needs ["Combinatorica" "] ;
edgeW[g_, e_] : = GetEdgeWeights[g, {e}][[l]];
plotWGraph[g_, 1_, r_, coll_, col2_] :=Module[{11},
11 = l ≈ Join ≈ (RotateLeft[#, 1] /@1) ;
GraphPlot[g, EdgeRenderingFunction ->
(If [MemberQ[ll, #2], {col1, Thickness [r edgeW[g, #2]],
Line[#2]}, {col2, Thickness [r edgeW[g, #2]],
Opacity[0. 4] , Line[#2]}] ),
VertexLabeling -> True] ] ) ]
Если множество вершин графа содержится в
In[76] : =
DynamicModule[{pts, pCG, pts0, w, mst, ее, delauney, showTr},
pts0= {{1, 0}, {0, 1}, {-1, 0}};
Manipulate [vv = Map[{#, VertexNumber -> True} , pts] ;
pCG = SetEdgeWeights [Graph [CompleteGraph [Length[pts] ] [[!]] , vv] ,
WeightingFunction -> Euclidean] ;
mst = MinimumSpanningTree[pCG]; ее = Edges[mst];
delauney = FromAdjacencyLists [#[[2]] /@ DelaunayTriangulation [pts] ] ;
Show[If[showTr, {showCG[Length[pts], pts, ее],
showGr[delauney, pts, {Black}]}, showCG[Length[pts], pts, ее]] ,
PlotRange -> {{-2, 2}, {-2, 2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True} ,
{{showTr, False, "Показать триангуляцию Делоне"}, {True, False}}],
Initialization: -> (Needs [ "Combinatorica'"] ;
Needs["ComputationalGeometry'"];
showCG [ n_, v_, edg_: { } ] : =
Graphics[GraphicsComplex[v,
If [MemberQ [edg, #11]]], {Red, Thickness [0 . 015] , Opacity [0 . 7] ,
Line[#[[l]]] } , {Blue, Dotted, Line [#[[1]] ] } ] /@
CompleteGraph [n] [[1]] ] ] ;
showGr[g_, v_, col_: {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line[Edges[g] ] ]]];)]
Триангуляция Делоне тесно связана с так называемой диаграммой Вороного конечного подмножества M евклидова пространства. Если $$M = \{m_1, \dots ,m_п\}, n \ge 2$$, то ячейкой Вороного точки $$m_i$$ называется множество $$W(m_i) = \{x| \rho (m_i,x) \le \rho (m_j,x) $$ для всех $$j\}$$, где через $$\rho$$, как и выше, обозначена функция расстояния. Ячейки Вороного точек двухточечного множества $$M = \{m_1,m_2\}$$ - суть полупространства (в двумерном случае - полуплоскости), порожденные серединным перпендикуляром к отрезку $$[m_1, m_2] $$. В общем случае - это выпуклые многогранные области, полученные пересечением соответствующих полупространств:
In[77] :=
Manipulate[DiagramPlot[ pp] ,
{(pp/ {{0, 0}/ {1- 0}}}, Locator, LocatorAutoCreate -> True}]
Триангуляция Делоне - это граф на множестве точек M евклидова пространства, две вершины которого соединены ребром-отрезком, если и только если ячейки Вороного этих вершин пересекаются по множеству коразмерности один. В случае плоскости - по отрезку или лучу.
In[78] : =
DynamicModule[{pts, pts0, vor, delauney},
pts0= {{1, 0}, {0, 1}, {-1, 0}, {0, -1}};
Manipulate[
delauney = FromAdjacencyLists [#|[2]] /@ DelaunayTriangulation[pts] ] ;
Show[{showDiaG[pts], showGr[delauney, pts, {Blue}]},
PlotRange -> {{-2, 2}, {-2,2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True}] ,
Initialization: -> (Needs [ "Combinatorica"'" ] ;
Needs["ComputationalGeometry'" ] ;
pairs [ls_] := Table [{Is [i] , Is |[i + 1]] } , {i , 1, Length [Is] - 1} ] ;
showGr[g_, v_f col_: {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line [Edges [gr] ] ] ] ] ;
showDiaGfpp ] := Module [ {hh, vd, In, edg, rs, els},
vd = VoronoiDiagram [pp] ; hh = Head[#] /@ vd[[l]| ;
In =
Union[
Sort /@ Flatten [pairs [#] /@
Select [ Table [ Select [vd [[2, i, 2] , hh[[#]| == List ] ,
{i, 1, Length [vd [[2]] }] , Length[#] > 1 ] , 1] ] ;
edg = Line[vd[[1]][[#]] ] /@ In; rs = Select [vd[[l]] , Head[#] == Ray ] ;
Graphics [edg ≈ Join ≈ (Line /@ Apply [List, rs , {1}])]];)]
На следующей картинке ячейки Вороного раскрашены в разные цвета:
In[79] :=
DynamicModule [ {pts, pts0, vor, delauney},
pts0 = {{1, 0}, {0, 1}, {-1, 0}, {0, -1}};
Manipulate[
delauney = FromAdjacencyLists[#[[2]] /@ DelaunayTriangulation[pts]] ;
Show[{showDia[pts], showGr[delauney, pts, {Blue}]},
PlotRange -> {{-2, 2} , {-2, 2}}] , {{pts, pts0}, Locator, LocatorAutoCreate -> True}] ,
Initialization: -> (Needs [ "Combinatorica" " ] ;
Needs["ComputationalGeometry'"];
showGr[g_ , v_ , col_ : {Blue}] : =
Graphics[GraphicsComplex[v, Append[col, Line [Edges [g]] ] ] ] ;
append[l_, r_] := Module [ {bg, en, res},
If [Length[r] ≠ 4, res = 1 ≈ Join ≈ r,
bg = r[[{l, 2}];
en = r[[{3, 4}];
Which[
bg[[1]] == 1[l] , res = {bgI2]; bgPI } ≈ Join ≈ 1,
bg[[2]] == 1[[l] , res = bg ≈ Join ≈ 1,
bg[[1]] == 1[[-l]], res = l ≈ Join ≈ bg,
bg[[2]] == 1[[-1]], res = 1 ≈ Join ≈{bg[[2]] , bg[[1]]}
];
Which[
en[[1]] ==1[[1]], res = {enI2I , en III }≈ Join ≈res ,
en[[2]] == 1[[1]], res = en ≈ Join ≈ res,
en[[1]] ==1[[-1]], res = res ≈ Join ≈ en,
en[[2]] ==1[[-1]], res = res ≈ Join ≈ {en[[2]], en[[1]]]}]
];
res
];
showDia[pp_] : = Module[{hh, vd. In, rs, els, pi},
vd = VoronoiDiagram[pp] ; hh = Head[#] /@vdlll ;
ln = vdIlH#I /@ Table [Select [vd[2, i, 2]| , hhl#] == List S] ,
{i, 1, Length[vdI2J]}];
rs = Map[If [Length[#] > 0, Flatten [Apply [List, it, 1] , 1] , {}] ,
vd[[1]][[#]] /@ Table [Select [vd [[2, i, 2]], hh[[#]] == Ray ] ,
{i, 1, Length[vd[[2]] ]}]] ;
cls = MapThread[append[#1, #2] , {In, rs}] ; pi = Polygon[#] /@ cls;
Graphics[Table[{EdgeForm[{Thick, Dashed}],
ColorData[Length[pp], "ColorList"][[i]], Opacity[0.7],
pl[[i]], Black, PointSize[0.02] , Point[pp[[i]] ] } ,
{i, 1, Length [pp]}]]];
)
]
Возвращаясь к задаче о ЕМОД, с помощью триангуляции Делоне можно построить квадратичный (по количеству вершин) алгоритм построения ЕМОД. А именно, сначала строим триангуляцию Делоне, а затем уже к ней применяем алгоритм Краскала:
In [80] : =
DynamicModule[{pts, ptsO, mst, ее, delauney, showTr},
pts0= {{1, 0}, {0, 1}, {-1, 0}};
showGr[g_, v_, col_: {Blue}] : =
Graphics [GraphicsComplex[v, Append [ col, Line [Edges [g-] ] ]]];
Manipulate[
delauney = SetEdgeWeights[
FromAdjacencyLists [#[[2]] /@ DelaunayTriangulation [pts] , pts] ,
WeightingFunction -> Euclidean] ;
mst = MinimumSpanningTree[delauney] ;
Show[
If[showTr, {showGr[mst, pts, {Red, Thickness[0.01], Opacity[0.7]}],
showGr[delauney, pts, {Blue}]},
showGr[mst, pts, {Red, Thickness[0.01]}]],
PlotRange ->
{{-2, 2}, {-2, 2}}], {{pts, pts0}, Locator, LocatorAutoCreate -> True} ,
{{showTr, False, "Показать триангуляцию Делоне"}, {True, False}}],
Initialization : -> (Needs [ "Combinatorica' " ] ;
Needs["ComputationalGeometry *"])
]
Замечание 7.3.1. На самом деле в общем случае алгоритм Краскала построения МОД работает со скоростью $$|E|ln|E|$$, а алгоритм построения ЕМОД, использующий триангуляцию Делоне, - со скоростью $$|V |ln|V |$$.
В качестве примера построим минимальные Mathematica включает в себя большие базы данных по естественным наукам, в частности, по географии. Эти базы данных, впрочем, находятся на сайте компании Wolfram, поэтому, чтобы ими пользоваться непосредственно, нужен доступ к сети. В приведенных примерах мы просто выкачали информацию о геометрической форме страны и ее флаге из базы CountryData, и координаты и названия крупных (больше 100000 жителей) городов выбранных стран из базы CityData. Отметим также наличие баз данных по молекулярной биологии, астрономии, физике, химии, лингвистике, финансам и пр. (см. Scientific Technical Data ).
In[81] : =
germCitiesCoord = {{{52.52 ", 13.38 "}}, {{53.55 ", 10. '}}{* ... *) } ;
ukCitiesCoord = {{{51.5", -0.1166667"}}, {{52.4666667", -1.9166667"}}
(* . . . *)};
germCitiesNames = {"Berlin", "Hamburg", "Munich", "Cologne" (* ... *)};
ukCitiesNames = {"London", "Birmingham", "Glasgow", "Liverpool" (* ... *)};
germPoly =
Polygon[{{{5.90725', 50.7242'}, {6.02985', 50.8203'}, {6.07395', 50.8833'},
{6.08445', 50.9323}, {6.05505', 50.9715}, {6.02985', 50.9785}
(* ... *)}, {{13.9187', 53.886'}, {13.8735', 53.8918},
{13.87', 53.9166'} (. ... *)} (* ... *)}];
ukPolygon =
Polygon[{{{-5.80035', 55.3191'}, {-5.83335', 55.3252'},
{-5.8559', 55.3505'}},
{{-7.1481', 55.1193-}, {-7.1613', 55.0969'}, {-7.154', 55.0852}
(* ... *)} (* ... * }];
sph[v_] := {Cos [v[[ll] Degree] Cos [v|[2]] Degree] ,
Cos [v[[ll] Degree] Sin [v[[2I] Degree] , Sin[v[[ll] Degree] } ;
geoDist[a_, b_] := N[2 ArcSin [Norm [sph [afl2]] ] - sph[b[[2]j] ] /2] ] ;
Needs["Combinatoricav"];
geoMST [ cnt_] : =
Module[{cts, ctsT, names, flag, poly, edges, gWeight, mst, col},
If[cnt == "Germany", cts = germCitiesCoord; names = germCitiesNames;
flag = gflag; col = LightOrange; poly = germPoly, cts = ukCitiesCoord;
names = ukCitiesNames; flag = ukflag; poly = ukPolygon; col = LightGray];
edges = Edges[CompleteGraph[Length[cts]] , All] ;
gWeight = SetEdgeWeights[Graph[edges, cts] , WeightingFunction -> geoDist] ;
mst = Edges[MinimumSpanningTree[gWeight]] ;
ctsT = Reverse /@ Flatten [cts, 1] ;
Graphics[{col, EdgeForm[Black], poly, Thick, Green,
MapThread[Line[{#2, 2}] , {ctsT[I^[[l]]I /@mst, ctsT[I#[[2I]I /@ mst}],
PointSize [Medium] , Red,
MapThread [Tooltip [Point [#1] , #2] , {ctsT, names}] ,
Inset[flag, {Right, Top}, {Right, Top}, 2]}]
];
GraphicsRow [geoMST [#] /@ { "Germany" , "UnitedKingdom" } ]
Также очень популярной является так называемая задача коммивояжера, состоящая в том, чтобы найти Mathematica реализован ряд приближенных методов решения задачи о коммивояжере, дающих точный ответ для малого числа вершин. Соответствующая функция называется FindShortestTour. По умолчанию весовая функция -
In [94] :=
Manipulate[
Graphics [
Line [р[[# ≈ Join ≈ {#[[1]]} @ Last [FindShortestTour [p] ]] ] ] ,
PlotRange -> {{-2, 2}, {-2, 2}}] ,
{{p, {{0, 1}, {1, 0}, {1, 1}}}, Locator,
LocatorAutoCreate -> True} ]
Снова пользуясь географическими базами данных, можно получить, например, такую картинку, описывающую оптимальный маршрут посещения всех стран мира:
С помощью триангуляции Делоне и диаграммы Вороного также легко решается, например, известная задача о ближайших соседях. А именно, ближайшими соседями точки $$m_i$$ из подмножества $$М =\{m_1 ,\dots, m_n\}$$ М на подмножества, составленные, в некотором смысле, из "близких" точек. Один из подходов состоит в
In [95] :=
DynamicModule[{pts, pts0, neibs},
pts0 = {{-1, -1}, {1, 0}, {0, 0}, {0, 1}, {1, 1}};
Manipulate[neibs = FromOrderedPairs[adLists[pts]];
Show[showOrGr[neibs, pts], PlotRange -> { { - 2 , 2}, {-2, 2}}],
{{pts, pts0}, Locator, LocatorAutoCreate -> True}],
Initialization:-> (Needs["Combinatorica""] ;
Needs["ComputationalGeometry' "];
showOrGr[g_, v_] :=
Module[{cmp}, cmp = WeaklyConnectedComponents[g] ;
Graphics[GraphicsComplex[ v,
{ColorData[3, "ColorList"] [[
Mod [Position [cmp, #[[1]] ] [[1, 1]], 10] + 1] ,
Arrow[#]}/@ Edges[g] ]]];
nearNeib[pts_, i_] := Module [ {delauney, min, dist} ,
delauney = #[[2]] /@ DelaunayTriangulation [pts] ;
dist = Norm [pts[[i]] - pts[[#]] ] /@ delauneyjij ;
min = Min[dist] ;
delauney[[i, Flatten[Position[dist, min] ] ]] ] ;
adLists[pts_] : =
Module[{nb, f},
nb = nearNeib [pts, #] /@ Range [Length [pts] ] ;
f [x_, y_] := {x, #} /@y;
Flatten[MapThread[f, {Range[Length[pts]], nb}] , 1]])]
Еще один пример оптимизационной задачи - знаменитая проблема Штейнера. На практике такая задача возникает при проектировании коммуникационных сетей, например, сети дорог, связывающей данные населенные пункты, или сети проводников, соединяющих различные элементы микросхемы. Обычно требуется, чтобы полученная сеть была оптимальна, скажем, имела наименьшую возможную длину. Похожую задачу мы уже разбирали, говоря о минимальном
Простейший вариант проблемы Штейнера известен как задача Ферма: построить на евклидовой плоскости такую точку, чтобы суммарное расстояние от нее до заданных трех точек, называемых терминалами, была наименьшей возможной. Ниже приведена визуализация решения этой задачи, причем терминалы задаются локаторами. Поэкспериментируйте с положением локаторов и попробуйте сформулировать определяющее свойство полученной сети:
In [96] : =
Manipulate[Module[{х, у, s},
s=
{х, у} /.
Las t@Quiet@FindMinimum [Plus @@ (Norm[{x, y} - #] /@p) ,
{{x, First©Mean[p]} , {y, Last@Mean[p]}} ,
Method -> "PrincipalAxis"];
Graphics [Line [{s, #}] /@p, PlotRange -> { {-2, 2}, {-1, 2}},
AspectRatio -> Automatic] ] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Внимательное изучение поведения сети показывает, что пока все три отрезка невырождены, углы между ними равны между собой и, значит, равны $$120^0$$, а когда один из отрезков вырождается, то угол между оставшимися отрезками не становится меньше, т.е. остается больше или равен $$120^0$$. Кроме того, дополнительные вершины не могут иметь степень 1 или 2. На самом деле это действительно так, причем даже в общем случае. Ниже приведен пример кратчайшей сети для четырех терминалов, как на плоскости, так и в трехмерном пространстве:
In [97] : = Manipulate [
Module {gl, g2, g3, g, xl, yl, x2, y2, min, res, resl, gr, sub, v,
e, st, dist, MyShowGraph},
$$\begin{matrix}
dist[v_{-}, w_{-}] : = \sqrt{(v - w) . (v - w)} ;
\end{matrix}
$$st[gr_, ls_] : =
Quiet@Module [ {w, ее, len} , vv = Vertices [g] ; ее = Edges[g] ;
len = Plus @@ (dist @@ vv[[#]] /@ ее) ;
FindMinimum [ len, {#, RandomReal [ ] } /@ Flatten[vv[[ls]]] ,
Method -> "PrincipalAxis"] ≈ Join ≈ {g}] ;
MyShowGraph[g_, opts : OptionsPattern[Graphics]] :=
Module[{vv, ее} , vv = Vertices[g]; ее = Edges[g] ;
Graphics [Line [vv[#] ] /@ ee, opts]] ;
gl = Graph[{{{l, 5}}, {{2, 5}}, {{5, 6}}, {{6, 3}}, {{6, 4}}},
({#} S/вр) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}];
g2 = Graph[{{{l, 5}}, {{3, 5}}, {{5, 6}}, {{6, 2}}, {{6, 4}}},
({#} S/ep) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}] ;
g3 = Graph[{{{l, 5}}, {{4, 5}}, {{5, 6}}, {{6, 3}}, {{6, 2}}},
({#} S/вр) ≈ Join ≈{{{xl, yl}}, {{x2, y2}}}] ;
g = {gl, g2, g3};
res = st[*f, {5, 6}] /@g;
min = Min[#|[l]] /@res] ;
resl = Select [res, #|[1]] == min ] // First;
gr = resl // Last;
sub = reslI2J; v = Vertices[gr] / . sub;
e = Edges [gr] ;
MyShowGraph [AddEdges [AddVertices [EmptyGraph [0] , v] , e] ,
PlotRange -> {{-2, 2}, {-2, 2}}]
],
{{p, {{-1, 1}, {-1, -1}, {1, -1}, {1, 1}}}, Locator},
Initialization : -> (
Needs["Combinatoricav"];
)
]
Замечание об управлении. При наведении курсора на граничную (красную) вершину сети (см. ниже), вершина становится желтой. Чтобы выделить граничную вершину сети, позиционируйте курсор на этой вершине и нажмите Ctrl. Вершина станет зеленой, "прикрепится" к курсору мыши и будет следовать за ним. Чтобы отпустить вершину, нажмите Shift. Вершина вновь станет красной. Нажимая левую клавишу мыши при курсоре, позиционированном на картинке, и двигая курсор, вы будете вращать картинку. Обратите внимание на скачкообразные перестройки структуры сети (
In [98]:=
DynamicModule[{pp, Locator3D, MyMean, testPoint, st, net4},
Locator3D[pts0_, ?_: Line] : =
DynamicModule [{pts, ppp, cur, с = False, covered = False, g, msAlt, bds, bm=-l,
bM = 1, ptsAlt, i - 1, testln = 2} ,
pts = pts0; ptsAlt = {0, 0, 0} ; msAlt ={{1.3, -2.4, 2.}, {-1.3, 2.4, -2.}};
cur = Dynamic[MousePosition["Graphics3DBoxIntercepts", msAlt]];
g=Graphics3D[Map[{Red, Sphere[#, 0.05]} ,
If [c, Drop[pts, {3}], pts] ] ≈ Join ≈
Table[
If [CurrentValue ["ControlKey"] bbcovered, с = True; msAlt = #; ptsAlt = pts[[j]] ;
If[CurrentValue["ShiftKey"], с = False];
testln = Length[CurrentValue[{"MousePosition", "GraphicsImageScaled"} ] ] ;
If [c, If [testln < 2, ptslij = ptsAlt] ;
bds = Transpose [AbsoluteOptions [g, PlotRange] [[1, 2]] ];
bm = 0 . 7 bds [[1]] ;
bM = 0 . 7 bds [[2]] ;
ppp = MyMean [pts [[j]] , #] ;
pts[[j]] = MapThread[Max[Min[#I, #3] , #2] , {ppp, bm, bМ}];
ptsAlt = pts[[j]];
msAlt = #] ;
If [c, If [i == j, {Green, Sphere[pts[[i]] , 0.07]}, {}],
If [ (testln >= 2) (testPoint[pts[[i]] , #] < 0.01 ) , covered = True; j = i;
{Yellow, Sphere[pts[[i]], 0.07]}, covered=False; {}]],
{i , 1, Length [pts] } ] ≈ Join ≈ {f[pts] } /@ cur,
Boxed -> True, PlotRange -> ({-1.3, 1.3}, {-1.3, 1.3}, {-1.3, 1.3}}],
Initialization : -> (
$$\begin{matrix}
MyMean[p_{-} , ms_{-} ] :=ms[[1]]+(ms[[2]]-ms[[1]]) \frac{(ms[[2]]-ms[[1]]).(p-ms[[1]])}{(ms[[2]]-ms[[1]]).(ms[[2]]-ms[[1]])};
\end{matrix}\\
\begin{matrix}
testPoint[p_{-}, ms_{-}] : =
\end{matrix}\\
\begin{matrix}
Module[\{v\}, v = p - ms[[1]]-(ms[[2]]-ms[[1]])\frac{(ms[[2]]-ms[[1]]).(p-ms[[1]])}{(ms[[2]]-ms[[1]]).(ms[[2]]-ms[[1]])};v.v];
\end{matrix}
$$)];
st[gr_, ls_] : =
Quiet@Module [{vv, ее, len} , vv = First @g; ее = Last@g;
len = Plus @@ (EuclideanDistance @@ vv[[#]] /@ee);
FindMinimum [ len, {#, RandomReal [ ] } /@ Flatten [w[[ls]] ] , Method -> "PrincipalAxis"]≈
Join ≈ {g-}] ;
net4[p_] := Module [ {gl, g2 , g3, gg, res, min, resl, gr, sub, v, e, xl, yl, zl, x2 , y2 , z2},
gl = {(# , /@p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}} ,
{{1, 5}, {2, 5}, {5, 6}, (6, 3}, {6, 4}}};
g2 = { (# /@p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}},
{{1, 5}, {3, 5}, {5, 6}, {6, 2}, {6, 4}}};
g3 = { (# /@ p) ≈ Join ≈ {{xl, yl, zl}, {x2, y2, z2}},
{{1, 5}, {4, 5}, (5, 6), {6, 3}, (6, 2}}};
gg = {gl, g2, g3} ; res = st[#, {5, 6}] /@gg; min = Min[#[[l]] /@ res] ;
resl = Select[res, #[[1]] == min ] // First; gr = resl // Last; sub = resl[[2]] ;
v = First@gr /. sub;
e = Last@gr;
Line[v[[#]] ] , /@ e] ;
рр={{-1, 0, -1}, {-1, 0, 0}, {-1, 1, 0}, {1/2, 1/2, 1/2}};
рр={{-1, 0, -1), {-1, 0, 0}, {-1, 1, 0}, {1/2, 1/2, 1/2}};
Locator3D[pp, net4]]
Из сказанного выше следует, что каждая кратчайшая сеть является деревом с терминалами степени не выше 3 и дополнительными вершинами степени 3. Отсюда вытекает, что если n - число терминалов, то дополнительных вершин может быть не больше n - 2 (проверьте). Тем самым имеется конечное, хотя и экспоненциально растущее с ростом n, число комбинаторных структур кратчайших сетей. Доказано, что проблема Штейнера на евклидовой плоскости является NP -трудной, т. е. скорее всего не существует полиномиального по n алгоритма построения кратчайшей сети.
Тем не менее в последнее время разработаны достаточно быстрые алгоритмы, позволяющие строить кратчайшие сети для сотен точек. Приведем визуализацию одного свойства решения задачи Ферма, лежащего в основе всех точных алгоритмов.
Если на сторонах треугольника построить правильные треугольники, пересекающие исходный только по его сторонам, то три окружности (изображенные красным цветом), описанные вокруг построенных треугольников, пересекутся в одной точке. В той же точке пересекутся и три отрезка (изображенные синим цветом), каждый из которых соединяет добавленную вершину построенного правильного треугольника с противоположной ей вершиной исходного.
Если в треугольнике, построенном на терминалах, все углы не превосходят $$120^0$$, то общая точка пересечения красных окружностей и синих отрезков совпадает с решением задачи Ферма. Если же некоторый угол больше или равен $$120^0$$, то решение задачи Ферма - вершина этого угла:
In [99]:=
Manipulate[
Module [ {pc, рр, i , sign, pt3 = { } , tri = { } , seg = { } ,
с, r, circ = { } , dist, vec} ,
$$\begin{matrix}
dist[v_{-}, w_{-}] : = \sqrt{(v - w) . (v - w)} ;
\end{matrix}
$$vec[v_] := {Re[v],Im[v]};
pp = p ;
For i = 1, i <= 3, i++,
pc = Complex @@ # /@ pp ;
sign = Sign[Det[{pp [[3]] -pp[[1]], pp[[2]] -PP[[1]] } ] ] ;
If[sign ≠ 0,
pt3=pc[[1]]e-sing i π/3 + pc[[2]] esing I π/3;
с = Mean [{pp [[1]], pp[[2]], vec@pt3}];
r = dist[c, pp[[1]]] ;
tri = tri ≈ Join ≈ {{pp[[1]] , pp[[2]] , vec@pt3, pp[[1]]}};
seg = seg ≈ Join ≈ { {vec@pt3, рр[[3]] } } ;
circ = circ ≈ Join ≈{ {с, r}};
];
pp = RotateLeft[pp];
] ,
Graphics [ { {Dashed} ≈ Join ≈ (Line /@ tri) } ≈ Join ≈ {Blue} ≈
Join ≈ (Line /@ seg) ≈ Join ≈ {Red} ≈ Join ≈
(Circle @@ # /@ circ) , PlotRange -> {{-2, 2}, {-2, 2}},
AspectRatio -> Automatic]
] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Если заменить
Поэкспериментируйте с примером, приведенным ниже, и постарайтесь сформулировать правило, описывающее направление отрезков.
In[100] :=
Manipulate[Module[{x, y, s, distManhat},
distManhat[v_, w_] : = Plus @@ Abs@ (v - w) ;
s =
{x, y} /.
Last@
Quiet @ FindMinimum [Plus @@ (distManhat [ {x, y} , #] /@p) ,
{{x, First@Mean[p]} , {y, Last@Mean[p]}} ,
Method -> "PrincipalAxis"];
Graphics [Line [{s, #}] /@p, PlotRange -> { {-2 , 2}, {-2, 2}},
AspectRatio -> Automatic] ] ,
{{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}
]
Ниже приведена реализация кратчайшей сети на манхеттенской плоскости в случае четырех терминалов. Обратите внимание на скачкообразное изменение кратчайшей сети при смещении терминалов. Эта особенность поведения сети объясняется неоднозначностью решения, в отличие от евклидова случая.
In [101] :=
Manipulate[
Module [{gl, g2 , g3, xl, yl, x2, y2 , min, res, resl, gr,
sub, v, e, distManhat, st, MyShowGraph} ,
distManhat[v_, w_] : = Plus @@ Abs@ (v - w) ;
st[g_, ls_] : =
Quiet@Module [ {w, ее, len} , w=Vertices[g];
ее = Edges [g] ; len = Plus @@ (distManhat @@vv[[#]] /@ee) ;
FindMinimum [len, {#, RandomReal [ ] } /@ Flatten [w[[ls]] ] ,
Method -> "Newton"] ≈ Join ≈ {g}] ;
MyShowGraph[g_, opts : OptionsPattern[Graphics]] : =
Module [ {vv, ее} , vv = Vertices [g] ; ее = Edges [g] ;
Graphics [Line [vv[[#]] ] /@ ее, opts] ] ;
gl = Graph[{{{l, 5}}, {{2, 5}}, {{5, 6}}, {{6, 3}},
{{6, 4}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g2 = Graph[{{{l, 5}}, {{3, 5}}, {{5, 6}}, {{6, 2}},
{{6, 4}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g3 = Graph[{{{l, 5}}, {{4, 5}}, {{5, 6}}, {{6, 3}},
{{6, 2}}}, ({#} /@p) ≈ Join ≈ {{{xl, yl}}, {{x2, y2}}}];
g= {gl, g2, g3}; res = st[#, {5, 6}] /@g; min = Min[#|[l]] /@res] ;
resl = Select [res, #[[1]] == min ] // First;
gr = resl // Last;
sub = resl [[2]] ;
v = Vertices[gr] /. sub;
e = Edges [gr] ;
MyShowGraph[AddEdges[AddVertices[EmptyGraph[0], v] , e] ,
PlotRange -> {{-2, 2}, {-2, 2}}]
],
{{p, {{-1, 1}, {-1, -1}, {1, -1}, {1, 1}}}, Locator},
Initialization : -> (
Needs["Combinatorica""];
)]
Отметим, что единичная окружность на манхеттенской плоскости является квадратом, диагонали которого лежат на координатных осях. Обобщением манхеттенской метрики являются так называемые $$\lambda$$ -нормы, для которых единичная окружность - правильный $$2 \lambda$$ -угольник. Ниже приводится визуализация кратчайших сетей на $$\lambda$$ -нормированной плоскости в случае трех терминалов. При $$\lambda > 2$$ вновь отмечается скачкообразное поведение сетей при cмещении терминальных точек, что опять же объясняется неоднозначностью решения.
In[102] :=
Manipulate [
Module {x, y, s, lin, vec, nrf norm, cr, len, res, gsol, distNorm} ,
vec[v_] :={Re[v], Im[v]};
nr = vec@# /@ Table [еI π/2(k+1/2) , {к, 0, λ - 1);
norm [v_] :=(Max@@(Abc[@.v]/@nr)/(nr[[1]].{1,0});
distNorm [v_, w_] : = norm [v - w] ;
cr = ParametricPlot[({Cos[ϕ],Sin[ϕ]})/(norm[{Cos[ϕ], Sin[ϕ]}]),{ϕ,0,2π},}
PlotStyle -> {Red}];
len = Plus @@ (distNorm[{x, y} , #] /@ p) ;
res = Quiet@FindMinimum[len, {{x, RandomReal [ ] } , {y, RandomReal [ ] }} ,
Method -> "Newton"];
s = {x, y} /. Last@res;
Show[{Graphics[Line[{s, #} ] /@ p, PlotRange -> { {-2 , 2} , {-2,2}},
AspectRatio -> Automatic] , cr}]
] , {{λ, 3}, Rest@Range[20] }, {{p, {{-1, 0}, {1, 0}, {0, 1}}}, Locator}]
Для получения официальных документов о завершении программы дополнительного профессионального образования (удостоверения о повышении квалификации, дипломов о профессиональной переподготовке и MBA) необходимо предоставить:
Внимание! Вы можете не заказывать доставку бумажной версии официального документы, а скачать его в электронном виде и распечатать самостоятельно. Информация о выданном документе в течение 1 месяца загружается в Федеральную информационную систему «Федеральный реестр сведений о документах об образовании и (или) о квалификации, документах об обучении» - ФИС ФРДО.
Доступ на новый сайт осуществляется с использованием адреса электронной почты, который был указан вами при регистрации на "старом". Мы постарались перенести все ваши данные с прежнего ресурса, однако не исключена вероятность потери части информации.
При возникновении проблемы со входом, воспользуйтесь функцией сброса пароля
Если вы обнаружите несоответствия, пожалуйста, сообщите нам.