Generowanie topologii schemat przestrzeń w Mathematica

Question

Mam kodu Mathematica w celu sprawdzenia, czy dany zbiór zestawów spełnia definicji topologii, chciałbym teraz programowo generować diagramy, takie jak:

Jak można to zrobić?

Answer 1

nie jestem zaznajomiony z problemem, ale do tworzenia diagramów z prymitywów, które wyglądają trochę jak te, które zostały wklejone, można to zrobić:

początek z „bazowej” sprawy -

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] 

Stąd wystarczy dodać elips do przypadku bazowego:

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] 

Zwróć uwagę, że ustawiam klatkę-> prawda podczas ich poprawiania, aby móc zobaczyć współrzędne.

Answer 2

Aby uzupełnić fajne diagramy Mike'a, tutaj jest sposób sprawdzenia, czy dowolna skończona lista list jest topologią, czyli (1) jeśli zawiera pusty zestaw, (2) zestaw podstawowy, (3) zamknięty ze skończonej przecięcia, oraz (3) zamyka się pod UNION:

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

użytkowych do sześciu przykładach

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

jak

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

daje

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

EDIT 1: W celu dalszego udoskonalenia preparatu, należy pamiętać, że operator

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

daje zbiór uzyskany poprzez podejmowanie wszelkich sum i części wspólnych elementów kolekcji zestawów . Kolekcja zestawów list jest topologią, jeśli jest to stały punkt operatora topoCover.Tak można określić alternatywną funkcję, aby sprawdzić czy list jest topologia:

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

Jeśli list nie jest topologia, topoCover daje Najmniejszy nadzbiór list który jest topologia. Więc

Complement[topoCover@#,#]& 

daje elementy mają zostać dodane do list aby topologii.

Można również rozważyć największy podzbiór (y) list, który jest topologią i element (y) do usunięcia z list w celu ich topologizacji. Odbywa się to za pomocą

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

Stosowanej, na przykład, do list6 jak

maxTopoSubset@list6 

mamy dwie topologie

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

Aby uzyskać elementy, które należy usunąć, aby uzyskać topologię od list, można użyć

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

Korzystanie z list6 jak

removeToTopologize@list6 

otrzymujemy

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

czyli usunięcie {2,3} lub {1,2} z list6 daje topologii.