在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

为了补充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@#}] &

与list6as一起使用

 removeToTopologize@list6

我们得到

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

也就是说,去除{2,3}或{1,2}从list6给出的拓扑结构.