tengo código de Mathematica para comprobar si una colección de conjuntos satisface la definición de una topología, ahora me gustaría generar mediante programación diagramas como éstas: 
Generar diagrama de espacio topológico en Mathematica
¿Cómo puede hacerse esto?
no estoy familiarizado con su problema, pero para crear diagramas de primitivas, que se ven un poco como los que usted ha pegado, se puede hacer esto:
comienzo con el caso "base" -
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]
Desde aquí sólo tiene que añadir elipses con el caso base:
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]
Tenga en cuenta que configuré Frame-> True al ajustar estos para poder ver las coordenadas.
Para complementar los geniales diagramas de Mike, aquí hay una manera de comprobar si una lista finita arbitraria de listas es una topología, es decir, (1) si contiene el conjunto vacío, (2) el conjunto base, (3) cerrados bajo intersecciones finitas, y (3) cerrado bajo unión:
topologyQ[x_List] :=
Intersection[x, #] === # & [
Union[
{Union @@ x},
Intersection @@@ [email protected]#,
Union @@@ #
] & @ Subsets @ x
]
aplicado a los seis ejemplos
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}};
como
topologyQ /@ {list1, list2, list3, list4, list5, list6}
da
{True, True, True, True, False, False}
EDIT 1: Para un refinamiento adicional de la formulación, tenga en cuenta que el operador
topoCover := (Union @@ {Union @@@ #, Intersection @@@ [email protected]#} &)@[email protected]# &
da la colección obtenida tomando todas las uniones e intersecciones de los elementos de una colección de conjuntos . Una colección de conjuntos list es una topología si es un punto fijo del operador topoCover.Así se puede definir una función alternativa para comprobar si es list topología:
topologyQ2 := ([email protected]# === #) &
Si list no es una topología, topoCover da smalles superconjunto de list que es una topología. Así
Complement[[email protected]#,#]&
da los elementos que se añadirán a list para que sea una topología.
También se pueden considerar los subconjuntos más grandes de list que es una topología y los elementos que se eliminarán del list para topologizar. Esto se hace mediante el uso de
maxTopoSubset := (If[{} == #, None, [email protected]#] &)@(GatherBy[
Select[[email protected]#, topologyQ], Length[#] &]) &
Aplicada, por ejemplo, a list6 como
[email protected]
obtenemos las dos topologías
{{}, {1, 2}, {1, 2, 3}}, {{}, {2, 3}, {1, 2, 3}}}
para obtener los elementos para ser retirado para conseguir una topología de list, uno puede usar
removeToTopologize := Table[Complement[#, Part[[email protected]#, i]], {i,
[email protected]@#}] &
Utilización con list6 como
[email protected]
obtenemos
{{{2, 3}}, {{1, 2}}}
, es decir, la eliminación de {2,3} o {1,2} de list6 da una topología.
+1 por ser tan conciso! Aquí estaba todo orgulloso de mí mismo por hacerlo en 9 líneas. Tendré que leer la función 'Rest' y el operador' @@ ', no había visto eso antes. – tlehman
'Rest' simplemente deja el primer elemento y toma el resto de la lista. '@@' es la abreviatura de 'Apply'. En este uso 'Y @@ Flatten' está reemplazando el encabezado' List' con el encabezado 'And'. También 'topologyQ/@ {list1, list2, list3, list4, list5, list6}' es suficiente. @kguler es 'Union @ Apply [Union, ...]' realmente necesario en la línea final? ¿No debería 'Aplicar [Unión, ...]' hacer el trabajo? –
@Tobi, gracias. En realidad, tomó varias iteraciones de prueba/error para que funcionase. Tuve que usar 'Rest' para deshacerme del conjunto vacío al comienzo de la lista' Subsets [] '. Por supuesto, todavía hay un amplio espacio para hacerlo más corto y más elegante. – kglr
Estoy buscando generar programáticamente una imagen para una cantidad variable de puntos. Creo que puedo generalizar esto, gracias por tu ayuda. – tlehman
Friggin dulce trabajo en los diagramas! Así que concéntrate en que tuve que reír. +1 fo sho. – telefunkenvf14
¡Maravilloso! Hacer doble clic en las imágenes y mover los objetos alrededor de una puede cubrir casos que son diferentes a los ejemplos de @ Tobi, p. Ej. el caso donde el subconjunto '{1,3}' es un elemento de la lista que requiere colocar puntos en un triángulo. – kglr