6
$\begingroup$
{{1, 2}, {1, 4}, {1, 6}, {1, 10}, {1, 12}, {1, 16}, {1, 18},
 {1, 22}, {1, 28}, {1, 30}, {2, 3}, {2, 5}, {2, 9}, {2, 11},
 {2, 15}, {2,17}, {2, 21}, {2, 27}, {2, 29}, {3, 4}, {3, 8},
 {3, 10}, {3,14}, {3, 16}, {3, 20}, {3, 26}, {3, 28}, {4, 7},
 {4, 9}, {4,13}, {4, 15}, {4, 19}, {4, 25}, {4, 27}, {5, 6},
 {5, 8}, {5,12}, {5, 14}, {5, 18}, {5, 24}, {5, 26}, {5, 32},
 {6, 7}, {6,11}, {6, 13}, {6, 17}, {6, 23}, {6, 25}, {6, 31},
 {7, 10}, {7,12}, {7, 16}, {7, 22}, {7, 24}, {7, 30}, {8, 9},
 {8, 11}, {8,15}, {8, 21}, {8, 23}, {8, 29}, {9, 10}, {9, 14},
 {9, 20}, {9,22}, {9, 28}, {9, 32}, {10, 13}, {10, 19}, {10, 21},
 {10, 27}, {10,31}, {11, 12}, {11, 18}, {11, 20}, {11, 26}, {11, 30},
 {11, 32}, {12, 17}, {12, 19}, {12, 25}, {12, 29}, {12, 31}, {13, 16},
 {13, 18}, {13, 24}, {13, 28}, {13, 30}, {14, 15}, {14, 17}, {14, 23},
 {14, 27}, {14, 29}, {15, 16}, {15, 22}, {15, 26}, {15, 28}, {15, 32},
 {16, 21}, {16, 25}, {16, 27}, {16, 31}, {17, 20}, {17, 24}, {17, 26},
 {17, 30}, {18, 19}, {18, 23}, {18, 25}, {18, 29}, {19, 22}, {19, 24},
 {19, 28}, {20, 21}, {20, 23}, {20, 27}, {21, 22}, {21, 26}, {21, 32},
 {22, 25}, {22, 31}, {23, 24}, {23, 30}, {24, 29}, {25, 28}, {26, 27},
 {27, 32}, {28, 31}, {29, 30}, {29, 32}, {30, 31}}

I would like to create a graph using this data set to describe the edges. How can I create a graph in mathematica using this data set. I will need to find a hamiltonian path after I create the graph. if you have any ideas about finding the hamiltonian path then please include that in your answer.

$\endgroup$
8
$\begingroup$

First a shorter way to get your list of pairs:

list = Select[PrimeQ @* Total] @ Subsets[Range @ 32, {2}]

Then, you can use FindHamiltonianPath on list directly without any additional processing:

FindHamiltonianPath @ list
 {29, 32, 15, 4, 3, 8, 23, 30, 11, 20, 21, 2, 9, 22, 31, 28, 13, 18,
  19, 24, 17, 26, 27, 16, 1, 10, 7, 12, 25, 6, 5, 14} 

You can use also Graph and FindHamiltonianCycle on list directly:

Graph @ list

enter image description here

FindHamiltonianCycle @ list

enter image description here

{EdgeList[Graph[list]] === EdgeList[Graph[UndirectedEdge @@@ list]],
 Sort @ VertexList[Graph[list]] == 
   Sort @ VertexList[Graph[UndirectedEdge @@@ list]]
{True, True}
HighlightGraph[list, PathGraph @ FindHamiltonianPath @ list,
   GraphHighlightStyle -> "Thick", PlotTheme -> "IndexLabeled"] 

enter image description here

Note: As far as I know, this usage does not appear in documentation. It seems to work if the list pairs contains only positive integers. Each pair {a, b} is treated as an undirected edge between a and b. The vertex list is taken to be the list of integers from 1 to Max@ pairs; that is, numbers in Range[Max @ pairs] that do not appear in pairs are treated as isolated vertices.

SeedRandom[1]
pairs = RandomInteger[{5, 10}, {4, 2}]
{{9, 7}, {9, 5}, {6, 5}, {5, 7}}
Graph[pairs, VertexLabels -> Placed["Name", Center], VertexSize -> 1]

enter image description here

Graph[pairs, DirectedEdges -> True]

enter image description here

Through[{VertexList, EdgeList}@Graph[pairs]]
{{1, 2, 3, 4, 5, 6, 7, 8, 9}, 
 {9 \[UndirectedEdge] 7, 9 \[UndirectedEdge] 5, 
  6 \[UndirectedEdge] 5, 5 \[UndirectedEdge] 7}}

The functions

  • EdgeList,
  • VertexList
  • ConnectedComponents
  • ConnectedGraphComponents
  • WeaklyConnectedComponents
  • WeaklyConnectedGraphComponents
  • VertexComponent
  • VertexInComponent
  • VertexOutComponent
  • KCoreComponents
  • FindGraphCommunities
  • FindCycle
  • FindKClan
  • FindKClub
  • FindKClique
  • HighlightGraph

also have this undocumented feature:

EdgeList[pairs]
  {9 \[UndirectedEdge] 7, 9 \[UndirectedEdge] 5,
   6 \[UndirectedEdge] 5, 5 \[UndirectedEdge] 7}
VertexList[pairs]
{1, 2, 3, 4, 5, 6, 7, 8, 9}
ConnectedComponents[pairs]
 {{5, 9, 6, 7}, {8}, {4}, {3}, {2}, {1}}

This works in both version 12.2.0 (Wolfram Cloud):

  $Version
 "12.2.0 for Linux x86 (64-bit) (November 16, 2020)"  

and in version 11.3.0 (Windows 10 64-bit)

  $Version
 "11.3.0 for Microsoft Windows (64-bit) (March 7, 2018)"
$\endgroup$
0
5
$\begingroup$

Assuming you are interested in DirectedEdges between the pairs, something like this will work:

Graph[ DirectedEdge@@@list ]

(where list is a variable storing your list of pairs above)

Unfortunately, this is not a Hamiltonian graph:

HamiltonianGraphQ[%] (*False*)

However, the undirected version does contain a Hamiltonian cycle:

FindHamiltonianCycle @ Graph[ UndirectedEdge@@@list] (*list of results showing the cycle*)

As noted in a subsequent answer, by default Graph interprets lists of pairs as a set of undirected edge instructions, so this is equivalent to:

FindHamiltonianCycle @ Graph[list]
$\endgroup$
3
  • 3
    $\begingroup$ Your first piece of code can be simplified to: Graph[DirectedEdge @@@ list] $\endgroup$ – SHuisman Jan 9 at 19:08
  • 2
    $\begingroup$ Indeed! My resolution for 2021 is to overcome my fear of the @@@ operator :-) Modified to account for this. $\endgroup$ – Joshua Schrier Jan 9 at 19:46
  • $\begingroup$ I describe is as 'applying it to a bunch' (mapping of an apply), which made me understand and memorize it years ago… $\endgroup$ – SHuisman Jan 9 at 19:56
3
$\begingroup$

after I posted this question I found the answer on the wolfram forums. first I found out how to use a rewriting rule to convert my list of lists into a list of undirected edges. then I used a built in function to find the hamiltonian path. some of these lines are here for debugging after Sort and DeleteDuplicates.

a = Flatten[
  Table[If[PrimeQ[x + y], {x, y}, ## &[]], {y, 32}, {x, 32}], 1]
b = Map[Sort, a, 1]
c = DeleteDuplicates[Sort[b]]
d = Table[
  If[c[[x]][[1]] != c[[x]][[2]], c[[x]], ## &[]], {x, Length[c]}]
Length[a]
Length[c]
Length[d]
e = Graph[UndirectedEdge @@@ d]
FindHamiltonianCycle[e]

this can be reduced to a one liner with the knowledge that the only even prime number is 1+1 and the lexicographical ordering of the set will have {1,1} first. therefore we drop the first element.

FindHamiltonianCycle[
 Graph[UndirectedEdge @@@ 
   Drop[DeleteDuplicates[
     Sort[Map[Sort, 
       Flatten[Table[
         If[PrimeQ[x + y], {x, y}, ## &[]], {y, 32}, {x, 32}], 1], 
       1]]], 1]]]
$\endgroup$

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.