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?
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.
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.
I wont be able to give a mathematica specific solution however i might share some insight considering finding all the topologies on a given finite set.
The naive algorithm (the one that checks topological space axioms) runtime would be around $2^2^n$. We will reduce the search space considerably. Key point to realize is that for every preorder on a finite set there is a topology and vice versa. Given a topology one can create a relation where $x \leq y$ iff $y$ is element of all the open sets which $x$ belongs to. I believe this is called specialization preorder. From a given preorder one can recover the topology by finding the upper sets.
So if we can find all the preorders on a given set, we can recover all the topologies. Finding preorders is considerably easier. A preorder is a binary relation which is transitive and reflexive. So the search space is $2^n^2$.
There are also cool algorithms (Floyd-Warshall ) to find the transitive closure of any given relation. Finding the reflexive closure is also easy (just add the identity matrix to the adjacency matrix represantation)
Related
The text in italics describes my general goal, if anyone is interested. Question is underneath.
I am trying to graph the energy levels of simple molecules using Mathematica 8. My method is crude, and goes as this:
Find eigenvalues of simple Hückel matrix.
Delete duplicates and determine size of list.
Evaluate the number of degeneracies by comparing duplicate list with no-duplicate list.
Create a n x 2 zero matrix where n is the number of unique energy levels.
5. Fill first column with unique energy levels, second column with degeneracies.
The matrix generated in step 5 can look like this:
(1 2)
(3 1) == M
(-1 1)
I wish to evaluate the maximum of column 2, and then find the value of the element in the same row, but in column 1. In this case, the answer I am looking for is 1.
These commands both evaluate to -1:
Extract[M[[All, 1]], M[[Max[M[[All, 2]]], 1]]]
M[[Max[M[[All, 1]]], 1]]
which is not the answer I want.
Any tips?
EDIT: This
Part[Part[Position[M, Max[M[[All, 2]]]], 1], 1]
works, but I don't understand why I have to use Part[] twice.
m = {{1, 2}, {3, 1}, {-1, 1}}
max = Max[m[[All, 2]]]
So find the position of the max and replace the second column with the first:
pos=Position[m, max] /. {x_,_}:>{x,1}
{{1,1}}
Then take the first element from pos, i.e. {1,1} and sub use it in Part
m[[Sequence ## First[pos]]]
1
But having said that I prefer something like this:
Cases[m, {x_, max} :> x]
{1}
The result is a list. You could either use First#Cases[...] or you might want to keep a list of results to cover cases where the maximum value occurs more than once in a column.
The inner Part gives you the first occurance of the maximum. Position returns a list of positions, even if there is only one element that has the maximum value, like this:
M = {{2, 2}, {2, 3}, {2, 2}, {1, 1}}
{{2, 2}, {2, 3}, {2, 2}, {1, 1}}
Position[M, Max[M[[All, 2]]]]
{{2, 2}}
So you want the first element in the first element of this output. You could condense your code like this:
Position[M, Max[M[[All, 2]]]][[1, 1]]
However, one thing that I think your code needs to handle better is this case:
M = {{3, 2}, {2, 3}, {2, 2}, {1, 1}}
3, 2}, {2, 3}, {2, 2}, {1, 1}}
Position[M, Max[M[[All, 2]]]]
{{1, 1}, {2, 2}}
You will get the wrong answer with your code in this case.
Better would be:
M[[All, 1]][[Position[M[[All, 2]], Max[M[[All, 2]]]][[1, 1]] ]]
Or alternatively
M[[Position[M[[All, 2]], Max[M[[All, 2]]]][[1, 1]], 1]]
If you only want a single column one value in the case of duplicate maximum values in column two I suggest that you make use of Ordering:
m = {{1, 3}, {1, 8}, {5, 7}, {2, 2}, {1, 9}, {4, 9}, {5, 6}};
m[[ Ordering[m[[All, 2]], -1], 1 ]]
{4}
In graph theory, we use the Hungarian Algorithm to compute a weighted bipartite graph's minimum edge cover (a set of edges that is incident to every vertices, the one with the minimum total weight.)
I find that in new version 8 of Mathematica, there is a whole new package of functions for Graph Theory, (begin with Graph[].) But I've not found any function that do this job. I do find a function called FindEdgeCover[] that can only find a edge cover, not the minimum one.
I did a few experiments and, although not documented, it seems that FindEdgeCover[] does what you want.
Consider for example:
h[list_] := CompleteGraph[4, EdgeWeight -> list]
FindEdgeCover[h#Range#6]
(*
-> {1->2,1->3,1->4}
*)
But
FindEdgeCover[h#Reverse#Range#6]
(*
-> {1->2,3->4}
*)
of course no warranty ...
Edit
Here you have some code to experiment with by using different weighted adjacency matrices
adj = {{\[Infinity], 1, 1, 1, 1}, {1, \[Infinity], 2, 2, 2},
{1, 2, \[Infinity], 2, 2}, {1, 2, 2, \[Infinity], 2},
{1, 2, 2, 2, \[Infinity]}}
g = WeightedAdjacencyGraph[adj];
g = WeightedAdjacencyGraph[adj, VertexShapeFunction -> "Name",
EdgeLabels ->
MapThread[
Rule, {EdgeList#g, AbsoluteOptions[g, EdgeWeight] /. {_ -> x_} -> x}],
GraphHighlight -> FindEdgeCover[g]]
NB: The code is not good at all, but I couldn't find a way to use EdgeLabels -> “EdgeWeight”. I posted this question to see if someone can do it.
Considering the following list :
dalist = {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
I would like to count the number of times a certain value in the first column takes a certain value in column 3.
So in this example my desired output would be:
{{1,1,2},
{1,0,1},
{2,1,0},
{2,0,2}}
or :
Where the latest sublist {2,0,2} being read as: When the value is 2 in the first column, a corresponding value (same row in matrices world) in column 3 of 0 is present twice.
I hope this is not to confusing. I added the second Column to convey the fact that the columns are distant to each other.
If possible, no reordering should happen.
EDIT :
{1,2,3,4,5}
{1,0}
are the exact values taken by the columns I am actually dealing with in my data.
I know I am missing the correct description. Please edit if you can and know it. Thank you
From what I understood, this should do it:
In[11]:= dalist = {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
Out[11]= {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
In[12]:= Map[Flatten, Tally[dalist[[All, {1, 3}]]]]
Out[12]= {{1, 1, 2}, {2, 0, 2}, {1, 0, 1}}
In your sample, you don't actually have the combination {2,1}, but you have the combination {2,0} twice, not once - thus the output is different from what you anticipated. That is, if I understood the question correctly.
I tried to come up with something brand new using Sasha's assumptions about the required output, but it got more similar to his code than I thought it would be. Still the differences are interesting enough to post.
{#1, #2, Count[dalist[[All, {1, 3}]], {##}]} & ###
Tuples[
{DeleteDuplicates#dalist[[All, 1]],
DeleteDuplicates#dalist[[All, 3]]}
]
Edit
With your clarification about the input the code can be simplified and actually improved to:
{#1, #2, Count[dalist[[All, {1, 3}]], {##}]}& ###Tuples[{Range[5],{0,1}}]
The first version is correct only if at least one example of each possible outcome is actually present in each column.
You can use a combination of Outer and Count:
In[39]:= Flatten[Outer[
{#1, #2, Count[dalist, {#1, _, #2}]} &,
DeleteDuplicates#dalist[[All, 1]],
DeleteDuplicates#dalist[[All, -1]] ], 1]
Out[39]= {{1, 1, 2}, {1, 0, 1}, {2, 1, 0}, {2, 0, 2}}
Here is a variation of Sjoerd's second method, that may or may not be easier to read and adapt.
Join ## Table[{i, j, dalist[[All, {1,3}]] ~Count~ {i, j}}, {i,5}, {j,0,1}]
One may use Array in the same manner:
Join ## Array[{##, dalist[[All, {1,3}]] ~Count~ {##}} &, {5,2}, {1,0}]
If your table is large, it will be worthwhile to do the extraction only once:
With[{x = dalist[[All, {1,3}]]},
Join ## Array[{##, x~Count~{##}} &, {5,2}, {1,0}]
]
I am trying to figure out a way to move two points, X and Y, independently of one another along the edges of an equilateral triangle with vertices A, B, and C. There are also some collision rules that need to be taken into account:
(1) If X is at a vertex, say vertex A, then Y cannot be on A or on the edges adjacent to it. i.e., Y can only be on vertices B or C or the edge BC.
(2) If X is on an edge, say AB, then Y cannot be on A, nor B, nor any of the edges adjacent to A and B. i.e., Y must be on vertex C
I have figured out how to move the two points along the triangle using a pair of sliders, but I can't figure out how to implement the collision rules. I tried using the Exclusions option for Slider but the results are not what I expect. I would prefer to drag the points along the triangle rather than using sliders, so if someone knows how to do that instead it would be helpful. Ideally, I would be able to
move the two points from a vertex to either one of the edges instead of coming to a stop at one of them. Here is my code so far.
MyTriangle[t_] :=
Piecewise[{{{-1, 0} + (t/100) {1, Sqrt[3]},
100 > t >= 0}, {{0, Sqrt[3]} + (t/100 - 1) {1, -Sqrt[3]},
200 > t >= 100},
{{1, 0} + (t/100 - 2) {-2, 0}, 300 >= t >= 0}}]
excluded[x_] := \[Piecewise] {
{Range[0, 99]~Join~Range[201, 299], x == 0},
{Range[0, 199], x == 100},
{Range[101, 299], x == 200},
{Range[0, 199]~Join~Range[201, 299], 0 < x < 100},
{Range[1, 299], 100 < x < 200},
{Range[0, 99]~Join~Range[101, 299], 200 < x < 300}
}
{Dynamic[t], Dynamic[x]}
{Slider[Dynamic[t], {0, 299, 1}, Exclusions -> Dynamic[excluded[x]]], Dynamic[t]}
{Slider[Dynamic[x], {0, 299, 1}, Exclusions -> Dynamic[excluded[t]]], Dynamic[x]}
Dynamic[Graphics[{PointSize[Large], Point[MyTriangle[t]],
Point[MyTriangle[x]],
Line[{{-1, 0}, {1, 0}, {0, Sqrt[3]}, {-1, 0}}]},
PlotRange -> {{-1.2, 4.2}, {-.2, 2}}]]
How about something like:
MyTriangle[t_]:=Piecewise[{
{{-1,0}+t {1,Sqrt[3]},1>t>=0},
{{0,Sqrt[3]}+(t-1) {1,-Sqrt[3]},2>t>=1},
{{1,0}+(t-2) {-2,0},3>=t>=0},{0,True}}]
and
Column[{
{Slider[Dynamic[x], {0, 3, .01}], Dynamic[x]},
{Slider[Dynamic[y], {0, 3, .01}], Dynamic[y]},
Dynamic[x = Mod[x, 3]; Which[
x==0.,Which[0.<=y<1.,y=1.,2.<y<=3.,y=2.],0.<x<1.,y=2.,
x==1.,Which[1.<=y<2.,y=2.,0.<y<=1.,y=0.],1.<x<2.,y=0.,
x==2.,Which[2.<=y<3.,y=0.,1.<y<=2.,y=1.],2.<x<3.,y=1.];
Graphics[{PointSize[Large], Point[MyTriangle /# {x, y}],
Line[{{-1, 0}, {1, 0}, {0, Sqrt[3]}, {-1, 0}}]}]]}]
Is there a cleaner way to do the following, assuming that I have a reason to keep the data sets independent?:
x = {1, 2, 3};
y = {1, 4, 9};
ListPlot[Partition[Riffle[x, y], 2]]
Thanks!
I do not think Timo's solution is standard.
Here are two methods, using Transpose or Thread, that I have often seen used.
x = {1, 2, 3};
y = {1, 4, 9};
Transpose[{x, y}]
Thread[{x, y}]
Output:
{{1, 1}, {2, 4}, {3, 9}}
{{1, 1}, {2, 4}, {3, 9}}
Both of these methods avoid explicitly referencing the length of your data which is plus in my book.
ListPlot[Transpose[{x, y}]]
ListPlot[{x,y}]
EDIT: #Davorak: it certainly will. If OP wants 'y against x' then
ListPlot[y]
would suffice. Either way, I don't understand the complicated answers to a very simple question. But then, I don't understand a lot of the questions on SO.