Генерация топологической пространственной диаграммы в Mathematica

Question

У меня есть код Mathematica, чтобы проверить, удовлетворяет ли набор множеств определению топологии, теперь я хотел бы программно генерировать диаграммы, подобные этим:

Как это можно сделать?

Answer 1

Я не знаком с вашей проблемой, но для создания диаграмм из примитивов, похожих на те, которые вы вставили, вы можете сделать это:

начать с «базового» случая -

base = {Circle[{-0.4, 0.4}, 0.1], Disk[{0, .125}, 0.05], 
   Text[Style["1", 24], {0, -0.1}],
   Disk[{0.5, .125}, 0.05], Text[Style["2", 24], {0.5, -0.1}], 
   Disk[{1., .125}, 0.05], Text[Style["3", 24], {1., -0.1}], 
   Circle[{.5, 0}, {.9, .5}]};

Graphics[{base}, ImageSize -> 220]

Отсюда просто добавьте elipses к базовому случаю:

Graphics[{base, Circle[{0, 0}, {.15, .3}]}, ImageSize -> 220]

Graphics[{base, Circle[{0, 0}, {.15, .3}], 
  Circle[{0.5, 0}, {.15, .3}], Circle[{0.25, 0}, {.58, .38}]}, 
 ImageSize -> 220]

Graphics[{base, Circle[{0.5, 0}, {.15, .3}], 
  Circle[{0.25, 0}, {.58, .38}], Circle[{0.75, 0}, {.58, .38}]}, 
 ImageSize -> 220]

Graphics[{base, Circle[{0.5, 0}, {.15, .3}], 
  Circle[{1, 0}, {.15, .3}], Red, AbsoluteThickness[6], 
  Line[{{-0.4, -0.5}, {1.4, 0.55}}], 
  Line[{{-0.4, 0.55}, {1.4, -0.5}}]}, ImageSize -> 220]

Graphics[{base, Circle[{0.25, 0}, {.58, .38}], 
  Circle[{0.75, 0}, {.58, .38}], Red, AbsoluteThickness[6], 
  Line[{{-0.4, -0.5}, {1.4, 0.55}}], 
  Line[{{-0.4, 0.55}, {1.4, -0.5}}]}, ImageSize -> 220]

Обратите внимание, что я настраивал Frame-> True при настройке, чтобы я мог видеть координаты.

Answer 2

В дополнение к классным диаграммам Майка, вот способ проверить, является ли произвольный конечный список списков топологией, то есть, (1) если он содержит пустой набор, (2) базовый набор, (3) закрытыйв конечных пересечениях и (3) закрыто в объединении:

topologyQ[x_List] :=
  Intersection[x, #] === # & [
    Union[
      {Union @@ x},
      Intersection @@@ Rest@#,
      Union @@@ #
    ] & @ Subsets @ x
  ]

Применительно к шести примерам

list1 = {{}, {1, 2, 3}};
list2 = {{}, {1}, {1, 2, 3}};
list3 = {{}, {1}, {2}, {1, 2}, {1, 2, 3}};
list4 = {{}, {2}, {1, 2}, {2, 3}, {1, 2, 3}};
list5 = {{}, {2}, {3}, {1, 2, 3}};
list6 = {{}, {1, 2}, {2, 3}, {1, 2, 3}};

подобно

topologyQ /@ {list1, list2, list3, list4, list5, list6}

дает

{True, True, True, True, False, False}

РЕДАКТИРОВАНИЕ 1: Для дальнейшего уточнения формулировки обратите внимание, что оператор

topoCover := (Union @@ {Union @@@ #, Intersection @@@ Rest@#} &)@Subsets@# &

дает коллекцию, полученную путем взятия всех объединений и пересечений элементов набора множеств.Набор множеств list является топологией, если он является фиксированной точкой оператора topoCover.Таким образом, можно определить альтернативную функцию для проверки, является ли list топологией:

 topologyQ2 := (topoCover@# === #) &

Если list не является топологией, topoCover дает наименьший надмножество list, которое является топологией.Поэтому

Complement[topoCover@#,#]&

дает элементы, которые нужно добавить к list, чтобы сделать его топологией.

Можно также рассмотреть наибольшее подмножество (ы) list, которое является топологией, и элемент (ы), которые нужно удалить из list, чтобы топологизировать его.Это делается с помощью

 maxTopoSubset := (If[{} == #, None, Last@#] &)@(GatherBy[
                     Select[Subsets@#, topologyQ], Length[#] &]) &

Применительно, например, к list6 как

 maxTopoSubset@list6

, мы получаем две топологии

 {{}, {1, 2}, {1, 2, 3}}, {{}, {2, 3}, {1, 2, 3}}}

Чтобы получитьэлементы, которые нужно удалить, чтобы получить топологию из list, можно использовать

 removeToTopologize :=  Table[Complement[#, Part[maxTopoSubset@#, i]], {i, 
                            Length@maxTopoSubset@#}] &

Используя с list6 как

 removeToTopologize@list6

, мы получим

 {{{2, 3}}, {{1, 2}}}

то есть удаление {2,3} или {1,2} из list6 дает топологию.