Mathematica中拓扑空间图的生成

我有一个代码来检查集合是否满足拓扑的定义，现在我想通过编程生成如下图表：

---

如何做到这一点？

我不熟悉您的问题，但要从基本体（看起来有点像您粘贴的基本体）创建图表，可以执行以下操作：

从“基本”案例开始--

从这里开始，只需将省略号添加到基本情况：

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

---

请注意，我在调整这些参数时设置了Frame->True，以便查看坐标。

为了补充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}};

像

给予

编辑1：为了进一步细化公式，请注意运算符

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

给出通过获取集合元素的所有并集和交集而获得的集合。如果集合

列表

是运算符

topoCover

的固定点，则集合

列表

是拓扑。因此，可以定义一个替代函数来检查

list

是否为拓扑：

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

如果

list

不是拓扑，

topoCover

给出

list

的smalles超集，这是一个拓扑。所以

Complement[topoCover@#,#]&

提供要添加到

列表中的元素，使其成为拓扑

也可以考虑<代码> >清单>代码>的最大子集，这是一个拓扑结构，并且要从<代码>清单>代码>中删除要对其进行拓扑化的元素。这是通过使用
 maxTopoSubset := (If[{} == #, None, Last@#] &)@(GatherBy[
                     Select[Subsets@#, topologyQ], Length[#] &]) &

例如，应用于
list6
as

 maxTopoSubset@list6

 removeToTopologize@list6

我们得到了这两种拓扑

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

要从
列表中获取要删除的元素以获取拓扑，可以使用

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

与列表6一起使用作为

 maxTopoSubset@list6

 removeToTopologize@list6

我们得到

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

也就是说，从
列表6
中删除
{2,3}
或
{1,2}
会给出一个拓扑。
我希望通过编程为可变数量的点生成一个图像。我想我可以概括一下，谢谢你的帮助。在图表上干得真好！所以我不得不笑了+1佛肖，太好了！双击图片并移动周围的对象可以覆盖与@Tobi示例不同的情况，例如子集
{1,3}
是列表中的一个元素，需要在三角形中放置点。+1非常简洁！在这里，我为自己在9行中的表现感到自豪。我必须仔细阅读
Rest
函数和
@
操作符，我以前从未见过这种情况。
Rest
只是离开第一个元素并获取列表的其余部分
@
是
Apply
的缩写。在这种用法中，
和@flant
将头
列表
替换为头
和
。另外
topologyQ/{list1，list2，list3，list4，list5，list6}

就足够了@kguler是

Union@Apply[Union，…]

在最后一行中真的需要吗？

不应该申请[Union，…]

做这项工作吗？@Tobi，谢谢。事实上，它花了相当多的尝试/错误迭代来让它工作。必须使用

Rest

删除

子集[]

列表开头的空集。当然，还有足够的空间使它更简洁、更优雅。@Mike，我从

Apply[Union，
，Rest@Subsets[list1]，1]
。在我检查成员资格之前，需要再次应用
Union
以消除重复元素。确定。我忽略了你对levelspec的使用。请注意，
Apply[Union，Rest@Subsets[list1]
返回
{{}，{1,2,3}}
，这是我在前面的评论中实际想到的。
 maxTopoSubset@list6

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

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

 removeToTopologize@list6

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