Question

我有mathematica代码来检查集合集是否满足拓扑的定义，我现在想以编程方式生成如下图： topological spaces

如何做到这一点？

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]

enter image description here

从这里只需将elipses添加到基本案例中：

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

enter image description here

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

enter image description here

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

enter image description here

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]

enter image description here

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]

enter image description here

请注意，我在调整这些时设置了Frame-＆gt; True，这样我就能看到坐标。

Answer 2

为了补充Mike的酷图，这里有一种检查列表的任意有限列表是否是拓扑的方法，即（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会产生拓扑。

Answer 3

我无法给出特定于 mathematica 的解决方案，但是考虑到在给定的有限集合上找到所有拓扑，我可能会分享一些见解。朴素算法（检查拓扑空间公理的算法）运行时间约为 $2^2^n$。我们将大大减少搜索空间。要实现的关键点是，对于有限集上的每个预序，都有一个拓扑，反之亦然。给定一个拓扑，可以创建一个关系，其中 $x \leq y$ 当当仅当 $y$ 是 $x$ 所属的所有开集的元素。我相信这被称为专业化预购。从给定的预序中，可以通过找到上集来恢复拓扑。因此，如果我们可以找到给定集合上的所有预序，我们就可以恢复所有拓扑。查找预订单要容易得多。前序是传递和自反的二元关系。所以搜索空间是$2^n^2$。还有很酷的算法 (Floyd-Warshall) 可以找到任何给定关系的传递闭包。找到自反闭包也很容易（只需将单位矩阵添加到邻接矩阵表示中）

在Mathematica中生成拓扑空间图

3 个答案: