Generating topological space diagram in Mathematica

Question

I have mathematica code to check whether a collection of sets satisfies the definition of a topology, I would now like to programmatically generate diagrams like these:

How can this be done?

Answer 1

I'm not familiar with your problem but to create diagrams from primitives, that look kind of like the ones you have pasted, you can do this:

start with the "base" case --

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]

From here just add elipses to the base case:

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]

Note that I set Frame->True while tweaking these so I could see the coordinates.

Answer 2

To complement Mike's cool diagrams, here is a way to check if an arbitrary finite list of lists is a topology, that is, (1) if it contains the empty set, (2) the base set, (3) closed under finite intersections, and (3) closed under union:

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

Applied to the six examples

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}};

like

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

gives

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

EDIT 1: For a further refinement of the formulation, note that the operator

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

gives the collection obtained by taking all unions and intersections of the elements of a collection of sets. A collection of sets list is a topology if it is a fixed point of the operator topoCover. So one can define an alternative function to check if list is topology:

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

If list is not a topology, topoCover gives the smalles superset of list which is a topology. So

Complement[topoCover@#,#]&

gives the elements to be added to list to make it a topology.

One can also consider largest subset(s) of list which is a topology and the element(s) to be deleted from list to topologize it. This is done by using

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

Applied, for example, to list6 as

 maxTopoSubset@list6

we get the two topologies

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

To get the elements to be removed to get a topology from list, one can use

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

Using with list6 as

 removeToTopologize@list6

we get

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

that is, removing {2,3} or {1,2} from list6 gives a topology.