1
$\begingroup$

Background: Lets first construct a square graph (the ha and second points define to implement periodic boundary condition):

points = Flatten[Table[{i, j}, {i, 0, 9}, {j, 0, 9}], 1];
list = 10 SortBy[Flatten[Table[{i, j}, {i, -1, 1}, {j, -1, 1}], 1], 
    Total[Abs@#] &];
points = Flatten[
   Table[(points\[Transpose] + x)\[Transpose], {x, list}], 1];
ha = Flatten[
   SortBy[GatherBy[
      AdjacencyMatrix[NearestNeighborGraph[points]][
       "NonzeroPositions"], First], #[[1, 1]] &][[1 ;; 
      Length@points/9]], 1];
gr = Graph[
   Select[DeleteDuplicates[
     Flatten[{#, 
         Reverse@#} & /@ ({ha[[All, 1]], 
          Mod[ha[[All, 2]] - 1, Length@points/9] + 1}\[Transpose]), 
      1]], #[[1]] > #[[2]] &]];

where gives,

enter image description here

now I want to assign each vortex, a neighboring face. I can do it by using the following trick

fc = FindCycle[mySquareGraph, {4}, All];

where some of them listed below

fc[[1 ;; 3]] // MatrixForm

enter image description here

and first face highlight as bellow

enter image description here

now I can list the points which make the faces coordinates,

FACE=fc[[All, All, 1]];
FACE[[1;;10]]//MatrixForm

enter image description here

Now assigning a vertex to a face becomes finding a nonrepetitive representation from this list. I try the following algorithm,

    M = Table[0, {i, 1, Length@fc}];
M[[1]] = FACE[[1,1]];
Do[M[[i]] = 
   DeleteCases[RandomSample@FACE[[i]], 
     Alternatives @@ M[[1 ;; i - 1]]][[1]];, {i, 2, Length@fc}]

I hoped M containers vortex position belonging to i'th face. However, this algorithm is failed. Consider I want to generalized to another graph. So let clear my question:

Question Consider following list,

{{1, 2, 12, 11}, {2, 12, 13, 3}, {3, 13, 14, 4}, {4, 14, 15, 5}, {6, 
  16, 15, 5}, {7, 8, 18, 17}, {7, 17, 16, 6}, {9, 10, 20, 19}, {9, 19,
   18, 8}, {11, 21, 22, 12}, {12, 13, 23, 22}, {13, 23, 24, 14}, {15, 
  16, 26, 25}, {15, 25, 24, 14}, {16, 17, 27, 26}, {27, 17, 18, 
  28}, {27, 26, 36, 37}, {27, 37, 38, 28}, {28, 18, 19, 29}, {28, 38, 
  39, 29}, {30, 20, 19, 29}, {30, 29, 39, 40}, {32, 31, 21, 22}, {33, 
  23, 22, 32}, {33, 43, 42, 32}, {34, 24, 23, 33}, {35, 25, 24, 
  34}, {35, 36, 26, 25}, {35, 45, 44, 34}, {35, 45, 46, 36}, {37, 38, 
  48, 47}, {37, 47, 46, 36}, {39, 40, 50, 49}, {39, 49, 48, 38}, {41, 
  31, 32, 42}, {41, 51, 52, 42}, {43, 44, 54, 53}, {43, 53, 52, 
  42}, {44, 43, 33, 34}, {45, 55, 54, 44}, {45, 55, 56, 46}, {47, 57, 
  58, 48}, {48, 49, 59, 58}, {49, 59, 60, 50}, {52, 51, 61, 62}, {52, 
  53, 63, 62}, {53, 63, 64, 54}, {55, 65, 66, 56}, {57, 47, 46, 
  56}, {57, 67, 66, 56}, {58, 59, 69, 68}, {58, 68, 67, 57}, {60, 59, 
  69, 70}, {61, 71, 72, 62}, {63, 62, 72, 73}, {63, 64, 74, 73}, {65, 
  55, 54, 64}, {65, 75, 74, 64}, {66, 67, 77, 76}, {68, 78, 77, 
  67}, {69, 79, 78, 68}, {73, 74, 84, 83}, {75, 65, 66, 76}, {75, 76, 
  86, 85}, {75, 85, 84, 74}, {80, 70, 69, 79}, {80, 90, 89, 79}, {81, 
  82, 72, 71}, {81, 91, 92, 82}, {82, 83, 73, 72}, {82, 92, 93, 
  83}, {83, 84, 94, 93}, {84, 94, 95, 85}, {85, 95, 96, 86}, {86, 87, 
  77, 76}, {87, 86, 96, 97}, {88, 78, 77, 87}, {88, 89, 79, 78}, {88, 
  98, 97, 87}, {89, 99, 100, 90}, {98, 88, 89, 99}}

Is there any general algorithm, find a group of a nonrepetitive representative from these lists. In other words, can we choose a member from each list, which not being identical?

$\endgroup$
4
  • $\begingroup$ Sorry, what is a plaque ? That's not a graph theory term I'm familiar with. $\endgroup$
    – flinty
    Aug 27 '20 at 17:36
  • $\begingroup$ I'm fairly sure your problem at the end of the question is one a difficult NP-Complete ones. You either frame it as a SAT problem and pass to FindInstance or do a brute force search with backtracking. It's like a tour on the graph SimpleGraph[ DeleteCases[ Flatten[Outer[DirectedEdge, #[[1]], #[[2]]] & /@ Partition[elements, 2, 1]], DirectedEdge[x_, x_]]] but unfortunately FindShortestTour is not implemented for directed graphs :( $\endgroup$
    – flinty
    Aug 27 '20 at 18:30
  • $\begingroup$ ^ you could use the resource function BacktrackSearch like this: BacktrackSearch = ResourceFunction["BacktrackSearch"]; result = BacktrackSearch[elements, DuplicateFreeQ, Sort[#] == Range[100] &] however this will take a very long time to find a solution. $\endgroup$
    – flinty
    Aug 27 '20 at 23:09
  • $\begingroup$ @flinty, sorry for any inconvenience. I change the plaque to face. I am thinking about your comment. I just need to calculate it ones in my calculation. $\endgroup$ Aug 28 '20 at 1:12
2
$\begingroup$

With faces defined as the list of 4-tuples in OP, we can construct a bipartite graph from faces to Union @@ faces using RelationGraph and use FindIndependentEdgeSet to find a matching:

vlist = Union @@ faces;
rg = RelationGraph[MemberQ, faces, vlist, ImageSize -> 900, 
  VertexSize -> Tiny, ImagePadding -> {{100, 50}, {5, 5}}, 
  VertexLabels -> {v_ :> Placed["Name", If[Head[v] === List, Before, After]]}, 
  PerformanceGoal -> "Quality"]

enter image description here

We can construct the edge list directly from faces without using RelationGraph:

edgelist = Flatten[Thread[DirectedEdge[#, #], List, {2}] & /@ faces];

After sorting edgelist is the same as EdgeList[rg]:

Sort[edgelist] == EdgeList[rg]
 True
g2 = Graph[edgelist, ImageSize -> 900, VertexSize -> Tiny, 
 ImagePadding -> {{100, 50}, {5, 5}}, 
 VertexLabels -> {v_ :> 
    Placed["Name", If[Head[v] === List, Before, After]]}, 
 PerformanceGoal -> "Quality", GraphLayout -> "BipartiteEmbedding"]

same picture

To get a system of distinct representatives for faces, we can use FindIndependentEdgeSet with rg or g2:

distinctrepresentatives = FindIndependentEdgeSet[rg]

enter image description here

SetProperty[rg, EdgeStyle -> {e_ -> Opacity[0], 
    Alternatives @@ distinctrepresentatives -> Red}]

enter image description here

Alternatively, we can use SparseArray`MaximalBipartiteMatching on AdjacencyMatrix of rg:

distinctrepresentatives2 =  SparseArray`MaximalBipartiteMatching[AdjacencyMatrix @ rg] /.
  {i_, j_} :>  DirectedEdge[faces[[i]], j - Length @ faces]

enter image description here

SetProperty[rg, 
 EdgeStyle -> {e_ -> Opacity[0], Alternatives @@ distinctrepresentatives2 -> Green}] 

enter image description here

$\endgroup$
4
  • $\begingroup$ thanks. Yes. This gives the answer. However, it is somehow slow. I changed the code to followings: $\endgroup$ Aug 28 '20 at 4:44
  • $\begingroup$ rg = Flatten[ ParallelTable[ Table[faces[[i]] [DirectedEdge] faces[[i, j]], {j, 1, Length@faces[[i]]}], {i, 1, Length@faces}], 1]; $\endgroup$ Aug 28 '20 at 4:44
  • $\begingroup$ @Rasoul-Ghadimi, please check if the alternative approach (constructing an edge list from faces directly without using RelationGraph) is any faster. $\endgroup$
    – kglr
    Aug 28 '20 at 5:05
  • $\begingroup$ because RelationGraph checks any element of both face and vertex group is slow. However, we know where the links are. I bring code in my previous comment. using RelationGraph takes a long time for 10000 points (unfinished task), but using face just takes about 0.3 seconds. Anyway, thank you for your post and answer. $\endgroup$ Aug 28 '20 at 5:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.