Off[General::spell1]; (* This package is part of "The Mathematica Explorer", Copyright 1997, Wolfram Research Inc., and may not be reproduced without written permission. *) (* The 4-coloring algorithm is described by Hutchinson and Wagon in Mathematica in Education and Research, volume 6, Number 1. Various heuristics for 4-coloring planar graphs, including a variation of the algorithm we use, are discussed by C. Morgenstern and H. Shapiro in Algorithmica, volume 6 (1991) pp. 869-891 and references therein. *) Left::usage = "Left is used to specify alignment in printforms such as ColumnForm and TableForm. It is also used to specify the exit direction for a special edge in ShowToroidalGraph."; Right::usage = "Right is used to specify alignment in printforms such as ColumnForm and TableForm. It is also used to specify the exit direction for a special edge in ShowToroidalGraph."; BeginPackage["Explorer`GraphColoring`", { "DiscreteMath`Combinatorica`", "DiscreteMath`Permutations`", "DiscreteMath`ComputationalGeometry`", "Graphics`Colors`", "Graphics`Shapes`", "Utilities`FilterOptions`"}]; MultiGraph::usage = "MultiGraph[a, v] represents a graph object where a is an adjacency matrix and v is a list of points in the plane that are vertices. An entrya can be 0 or 1, but it can also be a list of lists, indicating a collection of piecewise linear curves is to be used to connect the vertices."; DualMultiGraph::usage = "DualMultiGraph[m] gives the KultiGraph object that is the true dual graph of the map m in the sense that edges are included for every edge-segment of the map that defines an adjacency of two countries."; MultiGraphToGraph::usage = "MultiGraphToGraph[m] takes a MultiGraph m and turns it into a PlanarGraph object by adding vertices at each point on any of the multiedges."; PlanarGraphToPlanarMap::usage = "PlanarGraphToPlanarMap[g] takes a PlanarGraph object and turns it into a map consisting of the same vertex set and the faces defined by the graph."; PlanarGraphPLToGraph::usage = "PlanarGraphPLToGraph[p] takes a piecewise linear planar graph and turns it into a planar graph by adding vertices at all the bends on all the edges."; Boundary::usage = "Boundary[m_PlanarMap] returns the list of points forming the outer boundary of the map m."; AddExteriorFace::usage = "AddExteriorFace[m] gives the planar map obtained by adding an exterior face to the planar map p; really the exterior face is a moat."; InducedSubmap::usage = "InducedSubmap[PlanarMap[c,p],s] gives the submap induced by the countries whose indices in c are given in s."; StraightenEdges::usage = "StraightenEdges is an option to AdjacencyGraph and DualMultiGraph that causes piecewise linear edges to be replaced by single straight lines when that is possible so as to preserve planarity and the fact that the edges lie within the corresponding countries. This option takes more time, but produces visually more attractive dual graphs."; RepeatedStraightenings::usage = "RepeatedStraightenings is an option to AdjacencyGraph and DualMultiGraph that causes the straightening process to be repeated until there are no further changes."; FourColoringPL::usage = "FourColoringPL[g] gives a four-coloring of the PlanarGraphPL graph g, where the edges are given in piecewise linear form."; ShowTriangles::usage = "ShowTriangles is an option to PathDecomposition that causes a graphic showing the triangles of the polygon's triangulation to be shown, along with the paths to the edges. This works only when a triangulation is used for the path decomposition; for convex or near-convex polygons, suriangulation is unnecessary."; PathDecomposition::usage = "PathDecomposition[p] gives a set of disjoint paths from a special point in the polygon p to the midpoints of all the edges PathDecomposition[p, b] gives paths to the edges identified in b, which is a list of the indices of the first vertices of the edges."; MapAprilFools::usage = "MapAprilFools is a planar map that Martin Gardner published in 1975 as a joke. He told readers that it required five colors. It does not."; MapAprilFoolsHarder::usage = "MapAprilFoolsHarder is a variation of MapAprilFools that is a little harder to 4-color."; AdjacencyGraph::usage = "AdjacencyGraph[m] produces a PlanarMapPL object that is the graph that codes the adjacencies of the planar map m. Each vertex is inside the country it represents and the edges are represented by piecewise linear paths that stay inside the respective countries."; PlanarGraphPL::usage = "PlanarGraphPL[m, pts] represents a planar graph whose edges are piecewise linear. The edge data is given in the adjacency matrix m, where, instead of a 1, there should be points that define the edge. These objects are returned by AdjacencyGraph[PlanarMap[f, p]]. The ShowGraph and FourColoringPL functions work on PlanarGraphPL objects."; ToGraph::usage = "ToGraph[p] takes p, a PlanarGraphPL object, and turns it into a Graph object by replacing each edge datum in the matrix by a 1. The resulting drawing may or may not be planar, but the Graph structure can be used to, for example, compute degree sequences."; ConvexVertex::usage = "ConvexVertex[p] gives the index of a vertex of the polygon p that is a convex vertex. ConvexVertex[p,i] gives True if the ith vertex of the polygon p is a convex vertex."; Orientation::usage = "Orientation[p] gives +1 if the polygon p is given in counterclockwise order, -1 if it is clockwise."; Centroid::usage = "Centroid[p] gives the centroid of the polygon p. This is the center of gravity of the vertices."; AddEdges::usage = "AddEdges[g, e] adds the edges in the list e to the graph g."; AddVertexAndEdges::usage = "AddVertexAndEdges[g, s] adds a vertex to the graph g and connects it to the vertices in s. AddVertexAndEdges[g, s, p] places the new vertex at location p."; AlgorithmTrace::usage = "AlgorithmTrace is an option to FourColoring that generates a movie showing each step of Kempe's algorithm, with both successful and failed Kempe chains."; BorderPoints::usage = "BorderPoints is an option to ShowMap that controls whether the border points are shown."; BorderPointStyle::usage = "BorderPointStyle is an option to ShowMap that sets the style of the points on the borders."; Borders::usage = "Borders is an option to ShowMap that controls whether the border lines are shown."; BorderStyle::usage = "BorderStyle is an option to ShowMap that sets the style of the lines forming the borders."; Brelaz::usage = "Brelaz is a possible setting for the Method option to FourColoring. It is fast, but rarely succeeds in 4-coloring a planar graph."; ConnectedComponent::usage = "ConnectedComponent[g,v] gives the list of vertices in g that are in the connected component of v."; CountryColors::usage = "CountryColors is an option to ShowMap that specifies the colors to use on the countries."; DegreeSequenceOrdered::usage = "DegreeSequenceOrdered[g] gives the degrees of the vertices of the graph g, in order."; DeleteEdges::usage = "DeleteEdges[g_Graph, e_List] deletes the edges in e from the graph g. Also, DeleteEdges[n] is a possible setting to the EdgeDeletionMethod option to RandomPlanarGraph. It causes n random edges to be deleted from a random triangulation."; DeleteRandomEdge::usage = "DeleteRandomEdge[g] deletes a random edge from the graph g."; DeleteRandomEdges::usage = "DeleteRandomEdges[g, n] deletes n random edges from the graph g."; Down::usage = "Down is used to specify the exit direction for a special edge in ShowToroidalGraph."; EdgeDeletionMethod::usage = "EdgeDeletionMethod is an option to RandomPlanarGraph that sets the method by which edges are deleted. Choices are Random (default), None, or DeleteEdges[n]; the first deletes a random number of edges, the second deletes no edges, and the last deletes n random edges."; EdgeSet::usage = "EdgeSet[g_Graph] gives the set of edges of g."; EdgeStyle::usage = "EdgeStyle is an option to ShowColoredGraph, ShowGraph, and ShowLabeledGraph that sets the style of the edges."; EulerFormulaProofGraphs::usage = "EulerFormulaProofGraphs[m, oc:Blue] gives a list of pairs {colors, graphs} where the graphs are obtained by successively deleting edges from the planar map m and the colors are a list for coloring the faces so that new expanded countries can be colored properly. The ocean color is determined by oc."; ErreraGraph::usage = "ErreraGraph is a 17-vertex graph due to A. Errera that shows why Kempe's false proof of the four-color theorem is false."; EulerFormulaProofMovie::usage = "EulerFormulaProofMovie[m] generates a movie that illustrates an inductive proof of Euler's formula, V - E + F = 2, for the planar map m. The proof proceeds by deleting edges until only a single point remains, and so that V - E + F is unchanged."; FindPlanarEmbedding::usage = "FindPlanarEmbedding[g] tries random embeddings to find a planar embedding of g. Only small graphs g should be used, as the method is unlikely to succeed except for small graphs."; FiveColoring::usage = "FiveColoring[g] tries to give a five-coloring of the graph g. If g is planar, a 5-coloring is returned. If g is not planar either a 5-coloring is returned, or a proof of non-planarity is found. The method used (Heawood's) is based on induction by the deletion of a vertex of degree at most 5, and contraction when necessary."; FourColorCountries::usage = "FourColorCountries is an option to ShowMap that asks for the countries to be four-colored."; FourColoring::usage = "FourColoring[g] uses the Kempe chain method to 4-color the planar graph g, which must be given in in a planar representation (i.e., the point locations must be a planar embedding). The Method \[Rule] Brelaz option causes a faster method to be used (VertexColoring from Combinatorica), but one that, in fact, rarely yields a four-coloring. Kempe's method fails on some graphs, but if Randomize is set to True, the success rate is very high. The rate is even higher if Method is set to Kittell, which calls for a variation of Kempe's method to be used. The input can be either a PlanarGraph or Graph object."; GasWaterElectricityDiagram::usage = "GasWaterElectricityDiagram shows a diagam of the gas, water, electricity graph."; HighlightNeighbors::usage = "HighlightNeighbors is an option to ShowColoredGraph that, when set to n, causes the edges emanating from vertex n to be thickened."; HighlightEdges::usage = "HighlightEdges is an option to ShowColoredGraph that asks that some edges by drawn in a different style. Default is thick and black."; HighlightStyle::usage = "HighlightStyle is an option to ShowColoredGraph that specifies the style used to highlight the edges specified by the HighlightEdges option."; IdentificationArrows::usage = "IdentificationArrows is an option to ShowToroidalGraph that place arrows to show the edge-identifications."; K::usage = "K abbreviates CompleteGraph. K[n] creates a complete graph on n vertices. K[a,b,c,...,k] creates a complete k-partite graph of the prescribed shape."; K4MapInPlane::usage = "K4MapInPlane is a PlanarMap object that describes a map in the plane whose countries from a complete 4-vertex graph."; K4Planar::usage = "K4Planar is a planar representation of K[4]."; ErreraGraphOnSphere::usage = "ErreraGraphOnSphere shows the Errera counterexample to Kempe's proof as a map on a sphere."; KempeCounterexample::usage = "KempeCounterexample is the 17-vertex example found by A. Errera that shows that Kempe's proof is false."; KempeExamples::usage = "KempeExamples[n] contains data for pairs of graphs and color-lists that illustrate Kempe chain successes and failures. n must be 1, 2, 3, 4, or 5. The fifth example is a planar graph only (no colors) due to A. Errera, also available as ErreraGraph."; KempeOrder::usage = "KempeOrder[g, pre:{}] returns the removal-order of the vertices when vertices of degree 5 or less are d recursively; pre denotes precolored vertices that are to come at the end of the order."; Kittell::usage = "Kittell is a possible setting to the Method option for FourColoring. At each inductive step, Kempe's method is used. If the chains get tangled, then random Kempe switches are made, including switches of adjacent vertices (this is Kittell's idea, 1935). Typically, such random switches lead to an impasse resolution in 50 tries. Kittell's method successfully colors the Errera graph, which foils Kempe's method."; Kempe::usage = "Kempe is a possible setting to the Method option for FourColoring. At each inductive step, Kempe's method is used. If the chains get tangled, then an error message is generated."; KittellOnly::usage = "KittellOnly is a possible setting to the Method option for FourColoring. Whenever an inductive impasse is reached, random Kempe switches are made, including switches of adjacent vertices (this is Kittell's idea, 1935). Typically, such random switches lead to an impasse resolution in 50 tries."; KittellGraph::usage = "KittellGraph is a planar graph due to Kittell that foils Kempe's algorithm."; KittellTrace::usage = "KittellTrace is an option to FourColoring that, when True, causes some messages tracing Kittell's algorithm to be printed, provided Kittell's method is being used."; LabelOffset::usage = "LabelOffset is an option to ShowLabeledGraph and ShowColoredGraph. It can be a single number that specifies the amount that the graph label is d from the vertex, down and left, or it can be a list of pairs, being offsets applying to successive labels."; Labels::usage = "Labels is an option to ShowColoredGraph that causes vertex labels to be shown."; MakePointsCounterclockwise::usage = "MakePointsCounterclockwise[pts, q] reorders pts so they are counterclockwise as viewed from q."; MakeCounterclockwise::usage = "MakeCounterclockwise[poly] takes a polygon and makes it counterclockwise."; MapSmallExample::usage = "MapSmallExample is a 6-country map useful for quick illustrations of map concepts."; MapOfWesternEurope::usage = "MapOfWesternEurope is a PlanarMap object based on some western European countries."; MapOfUSA::usage = "MapOfUSA is a PlanarMap object representing the contiguous states of the United States."; MaxDegree::usage = "MaxDegree[g] gives the maximum degree of the vertices of the graph g."; MaxTries::usage = "MaxTries is an option to FourColoring that sets the maximum number of random switches to try when Kittell's method is used. MaxTries is also an option to FindPlanarEmbedding that sets the maximum number of random embeddings that will be tried."; MinDegree::usage = "MinDegree[g] gives the minimum degree of the vertices of the graph g."; MooreGraph::usage = "MooreGraph is a 341-vertex planar graph that is a little resistant to 4-coloring."; MooreGraphPartial::usage = "MooreGraphPartial is a partial version of the Moore graph. Some edges are missing, but it still serves as an excellent test for 4-coloring, and is easier to draw."; MooreGraphPartialFourColoring::usage = "MooreGraphPartialFourColoring gives a four-coloring of the partial Moore graph."; Neighbors::usage = "Neighbors[g, i] gives the list of vertices in g that are adjacent to i."; NFaces::usage = "NFaces[m] gives the number of countries of a planar map m, excluding exterior."; NiceColorSet::usage = "NiceColorSet is a list of nice colors. Their names are in NiceColorSetNames."; NiceColorSetNames::usage = "NiceColorSetNames are the names of the nice colors in NiceColorSet."; Normalized::usage = "Normalized is an option to ShowColoredGraph and ShowGraph and ShowLabeledGraph that, when False, causes the actual coordinates in the graph object to be used, as opposed to normalized coordinates.";\[AliasDelimiter]\[AliasDelimiter]\[AliasDelimiter] PermuteLabels::usage = "PermuteLabels[g, p] permutes the labels of the graph g according to the permutation p."; PlanarCheck::usage = "PlanarCheck is an option to FourColoring and FiveColoring with the Kempe option and to StraightLineAdjacencyGraph. When False it suppresses a check that the graph is really a planar embedding. PlanarGraph objects automatically suppress this check."; PlanarEmbeddingQ::usage = "PlanarEmbeddingQ[g] gives True if the graph in g is given in a planar form, assuming straight lines form the edges."; PlanarGraph::usage = "PlanarGraph[a, v] represents a graph object where a is an adjacency matrix and v is a list of points in the plane that are vertices and the embedding is planar when straight lines are used for the edges. Most functions that work on graphs will also work on planar graphs. But functions such as AddVertex and AddEdge do not work!"; PlanarGraphFromTriangulation::usage = "PlanarGraphFromTriangulation[pts] gives a planar graph based on a Delaunay triangulation of pts. It returns a PlanarGraph object."; PlanarMap::usage = "PlanarMap[face, pts] represents a planar map where pts are all the border points and faces are the indices of the faces (or countries) in counterclockwise order. Three counting functions work on PlanarMaps (V, M, NFaces)"; StraightLineAdjacencyGraph::usage = "StraightLineAdjacencyGraph[m] gives the PlanarGraph that has vertices inside the countries and straight-line edges for adjacent countries of the PlanarMap m. There is a possibility, in a case where the countries are nonconvex, that the graph will not be a planar embedding. This can be checked via PlanarCheck option."; PlanarMapToGraphOfMap::usage = "PlanarMapToGraphOfMap[m] gives the planar graph that coincides with the planar map m."; Precolored::usage = "Precolored is an option to FiveColoring when the Kempe method is used, and to FourColoring. If set to{{v1, m1}, {v2, m2},...}, the colors mi are preassigned to the vertices vi. They can be changed by Kempe chains as the algorithm proceeds, but can be used to force various algorithmic behaviors."; Randomize::usage = "Randomize is an option to FourColoring that causes the induction to be based on a random choice of vertex of smallest degree. This makes it difficult for the program to choke on tangled Kempe chains! The implementation is by an initial random shuffling of the (nonprecolored) vertex labels."; RandomLabeling::usage = "RandomLabeling[g] relabels the graph g in a random fashion."; RandomPlanarGraph::usage = "RandomPlanarGraph[n] generates a random PlanarGraph object having n vertices. A Delaunay triangulation on random points is used, and the default is to produce a triangulated graph. For more variety the EdgeDeletionMethod option can be used to delete a random or a fixed number of edges. The graph might then have isolated vertices."; RandomPlanarMap::usage = "RandomPlanarMap[n] generates a planar map object by starting with n random points, using a Delaunay triangulation of the points, and then forming the map defined by the centroids of the triangles."; ReducibleExample::usage = "ReducibleExample is an example of a reducible configuration, such as might be used in a proof of the four-color theorem."; ShowColoredGraph::usage = "ShowColoredGraph[g, c, (opts)] shows the graph g with the vertices colored according to the vertex-coloring in c."; ShowAdjacencyGraph::usage = "ShowAdjacencyGraph is an option to ShowMap that causes the adjacency graph to be superimposed. Options for ShowGraph may be used."; ShowEulerFormulaData::usage = "ShowEulerFormulaData is an option to ShowMap that shows data that illustrate Euler's V - E + F = 2 formula."; ShowMap::usage = "ShowMap[m] shows the planar map m. Options can be used to add a label illustrating Euler's formula, superimpose the dual graph to the map, and color the map in 4 colors (with notable exceptions for which Kempe's algorithm fails)."; ShowToroidalGraph::usage = "ShowToroidalGraph[g_Graph] shows g on a flat torus. The SpecialEdges option is used to indicate which edges wrap around the flat torus, and how. The TorusRange option sets the size of the rectangle."; ShowVertexFaceEdgeData::usage = "ShowVertexFaceEdgeData is an option to ShowMap that shows counts of the vertices, faces, and edges."; SignedArea::usage = "SignedArea[polygon] gives the signed area of a polygon."; SoftColorsPlus::usage = "SoftColorsPlus[g] is a list of 4 soft colors suitable for graph or map coloring, with a fifth color or shade, g, added for use with an uncolored vertex or country."; SpecialEdgeStyle::usage = "SpecialEdgeStyle is an option to ShowToroidalGraph that specifies the default style for edges that wrap around the flat torus. But this can be overridden in the fourth entry of each special edge."; StateNames::usage = "StateNames is a list of two-letter U.S. state abbreviations in alphabetical order."; TorusRange::usage = "TorusRange s an option to ShowToroidalGraph that specifies xmax and ymax for the rectangle that rperesnts the torus."; PrintTraceData::usage = "PrintTraceData is an option to FourColoring that causes some tracing data to be printed."; TraceIncrement::usage = "TraceIncrement is an option to FourColoring that sets the interval for printing vertex trace data when the PrintTraceData option is on."; Triangulate::usage = "Triangulate[poly] returns the indices of a triangulation of the polygon poly."; Up::usage = "Up is used to specify the exit direction for a special edge in ShowToroidalGraph."; USChallengeSolution::usage = "USChallengeSolution gives a 4-coloring for the US states (and Lake Michigan) with the fourth color occurring only two times."; VertexColors::usage = "VertexColors is an option to ShowColoredGraph that specifies the colors to use. The default setting of Automatic causes the colors in NiceColorSet to be used."; VertexSize::usage = "VertexSize is an option to ShowColoredGraph, ShowGraph, and ShowLabeledGraph that sets the vertex size. It must be either PointSize[r] or AbsolutePointSize[r] or Automatic."; VertexStyle::usage = "VertexStyle is an option to ShowToroidalGraph that sets the vertex style."; VertexColor::usage = "VertexColor is an option to ShowGraph and ShowLabeledGraph that sets the color of the vertices."; RandomPlanarMap::badarg = "The argument must be an integer greater than 4."; FiveColoringKempe::nonplnar = "The embedding of the input is not a planar embedding."; FourColoring::nonplnar = "The embedding of the input is not a planar embedding."; FiveColoringMaxDegreeFour::stuck = "The recursion ran into a place where there were no free colors."; FiveColoring::nonpln = "The graph is not planar because a subgraph violates Euler's formula."; FiveColoring::hasK6 = "The graph is not planar because it contains a K[6]."; FiveColoringKempe::nonpln = "The graph is not planar because a subgraph violates Euler's formula."; FiveColoringKempe::subdv = "The graph is not planar because it contains a subdivision of K[5]."; FourColoring::kittel = "Kempe's method led to tangled chains and now Kittell's method of trying random Kempe switches, including \"tangent switches\" is being tried."; FourColoring::badpre = "The setting of the Precolored option must be a list of pairs of integers."; FourColoring::failed = "The Kempe chains got tangled. If the graph and its embedding are indeed planar, then the graph is an example of how Kempe's supposed proof of the Four-Color Theorem fails. Setting the Method option to Kittell causes a more sophisticated method to kick in when the chains get tangled."; FourColoring::incon = "Precolored vertices cannot be used with Brelaz's method of graph coloring."; FourColoring::fail ="Brelaz's heuristic failed to 4-color the graph; it produced a coloring with `` colors."; FourColoring::subdv = "The graph is not planar because it contains a subdivision of K[5]."; GraphColoring::nonpln = "The input graph is not planar."; FindPlanarEmbedding::mxpast = "The maximum number of tries has been exceeded. Try increasing the setting of the MaxTries option."; StraightLineAdjacencyGraph::cnvltd = "The convoluted nature of the countries has yielded a graph that is planar, but such that the embedding is not planar."; Begin["`Private`"]; NiceColorSetNames = (Join[#1, Complement[AllColors, Join[#1, {"NavyBlue", "Black", "White"}]]] &)[{"Red", "Green", "Blue", "Yellow","Magenta", "LemonChiffon", "DarkOrchid", "LightSalmon", "LightPink", "Sienna", "Green", "Mint", "DarkSlateGray", "ManganeseBlue", "SlateGray", "DarkOrange", "MistyRose", "DeepNaplesYellow", "GoldOchre", "SapGreen"}]; NiceColorSet = ToExpression /@ NiceColorSetNames; Unprotect[Edges, Vertices, DegreeSequence, M, Vertices, V, ShowGraph, DeleteEdge, DeleteVertex, ShowLabeledGraph, MinimumSpanningTree, GraphUnion, VertexColoring, ConnectedComponents, ConnectedQ, NormalizeVertices, PointsAndLines, FindCycle, TreeQ, FindCycle, ToAdjacencyLists, InduceSubgraph]; ToAdjacencyLists[g_PlanarGraph] := ToAdjacencyLists[Graph @@ g] ToAdjacencyLists[g_PlanarGraphPL] := ToAdjacencyLists[ToGraph[g]] FindCycle[g_PlanarGraph] := FindCycle[Graph @@ g]; Edges[g_PlanarGraph] := Edges[Graph @@ g] TreeQ[g_PlanarGraph] := TreeQ[Graph @@ g] Vertices[PlanarGraph[g__]] := Vertices[Graph[g]] M[PlanarGraph[g__]] := M[Graph[g]] EdgeSet[PlanarGraph[g__]] := EdgeSet[Graph[g]] V[PlanarGraph[g__]] := V[Graph[g]] V[PlanarMap[f_, v_]] := Length[v]; NFaces[PlanarMap[f_, v_]] := Length[f]; M[PlanarMap[f_, v_]] := Length[Union @@ (Sort /@ Partition[extend[#], 2, 1]& /@ f)] PlanarEmbeddingQ[g_PlanarGraph] := True FindPlanarEmbedding[g_PlanarGraph] := g MinimumSpanningTree[g_PlanarGraph] := MinimumSpanningTree[Graph@@g] VertexColoring[g_PlanarGraph] := VertexColoring[Graph@@g] ConnectedComponents[g_PlanarGraph] := ConnectedComponents[Graph@@g] ConnectedComponent[g_PlanarGraph | g_Graph, v_] := FixedPoint[Union[#, Neighbors[g, #]] &, {v}] ConnectedQ[g_PlanarGraph] := ConnectedQ[Graph@@g] EdgeSet[g_Graph] := Union[Sort /@ Position[Edges[g], 1]] DeleteEdges[g_PlanarGraph, s_] := PlanarGraph @@ DeleteEdges[Graph @@ g, s] DeleteEdge[PlanarGraph[g__], s_] := PlanarGraph @@ DeleteEdge[Graph[g], s] DeleteVertex[g_PlanarGraph, i_] := PlanarGraph @@ DeleteVertex[Graph @@ g, i] DeleteVertex[g_PlanarGraphPL, i_] := PlanarGraphPL[(Delete[#, i]& /@ Delete[g[[1]], i]), Delete[g[[2]],i]] DeleteRandomEdge[PlanarGraph[g__]] := PlanarGraph @@ DeleteRandomEdge[Graph[g]] DeleteRandomEdges[g_PlanarGraph, s_] := PlanarGraph @@ DeleteRandomEdges[Graph @@ g, s] InduceSubgraph[g_PlanarGraph, verts_] := PlanarGraph @@ InduceSubgraph[Graph @@ g, verts] GraphUnion[g1_PlanarGraph, g2_PlanarGraph] := PlanarGraph @@ GraphUnion[Graph @@ g1, Graph @@ g2] DegreeSequence[g_PlanarGraph] := DegreeSequence[Graph @@ g] DegreeSequenceOrdered[g_PlanarGraph] := DegreeSequenceOrdered[Graph @@ g] ShowColoredGraph[g_PlanarGraph, c_, opts___] := ShowColoredGraph[Graph @@ g, c, opts] ShowColoredGraph[g_PlanarGraphPL, c_, opts___] := Show[Block[{$DisplayFunction = Identity}, {ShowGraph[g, opts], ShowColoredGraph[Graph[IdentityMatrix[Length[g[[2]]]], g[[2]]], c,opts]}]] NormalizeVertices[g_PlanarGraph] := PlanarGraph @@ NormalizeVertices[Graph @@ g] FindCycle[g_PlanarGraph] := FindCycle[Graph @@ g] PointsAndLines[g_PlanarGraph] := PointsAndLines[Graph @@ g] MaxDegree[g_PlanarGraph] := MaxDegree[Graph @@ g] MinDegree[g_PlanarGraph] := MinDegree[Graph @@ g] Neighbors[g_PlanarGraph, v_] := Neighbors[Graph @@ g, v] FourColoring[g_PlanarGraph, opts___] := FourColoring[Graph @@ g, PlanarCheck -> False, opts] FourColoring[g_PlanarGraphPL, opts___] := FourColoringPL[g, PlanarCheck -> False, opts] FiveColoring[g_PlanarGraph] := FiveColoring[Graph@@g] Protect[FindCycle, Edges, Vertices, V, M, ShowGraph, DeleteEdge, DeleteVertex, ShowLabeledGraph, DegreeSequence, GraphUnion, ConnectedComponents, ConnectedQ, NormalizeVertices, PointsAndLines. FindCycle, TreeQ, ToAdjacencyLists, InduceSubgraph]; DeleteRandomEdge[g_Graph] := DeleteEdge[g, EdgeSet[g][[Random[Integer,{1,Length[EdgeSet[g]]}]]]] DeleteRandomEdges[g_Graph, n_] := Module[ {r = RandomKSubset[EdgeSet[g], n]}, Graph[b = ReplacePart[g[[1]], 0, r]; b * Transpose[b], g[[2]]]] PlanarEmbeddingQ[g_Graph] := Module[{ed}, ed = (g[[2]][[#1]] & ) /@ EdgeSet[g]; (!Apply[Or, Apply[Intersect, KSubsets[g[[2,#]]& /@ EdgeSet[g],2],{1}]])] Options[FindPlanarEmbedding] = {MaxTries -> 100}; FindPlanarEmbedding[g_Graph, opts___] := Module[ {pl = False, g1, c = 0, max, hf = HoldForm[FindPlanarEmbedding[g]]}, max = MaxTries /. {opts} /. Options[FindPlanarEmbedding]; If[!PlanarQ[g], Message[GraphColoring::nonpln]; Return[hf]]; While[!pl, c++; If[c > max, Message[FindPlanarEmbedding::mxpast]; Return[hf]]; pl = PlanarEmbeddingQ[g1 = RandomVertices[g]]]; PlanarGraph @@ g1] MakeOnes[l_, n_] := ReplacePart[Array[0 &, n], 1, List /@ l] PlanarGraphFromTriangulation[pts_, dt_:Automatic] := PlanarGraph[MakeOnes[Last@#, Length[pts]] & /@ If[dt === Automatic, DelaunayTriangulation[pts], dt], pts] MakePointsCounterclockwise[pts_, offset_] := Sort[N[pts], Arg[Complex @@ (#1-offset)] < Arg[Complex @@ (#2-offset)]&] Options[RandomPlanarGraph] = {EdgeDeletionMethod -> None}; RandomPlanarGraph[n_, opts___] := Module[ {edm, g, hf = HoldForm@RandomPlanarGraph[n,opts]}, edm = EdgeDeletionMethod /. {opts} /. Options[RandomPlanarGraph]; edm = edm /. None -> DeleteEdges[0]; g = PlanarGraphFromTriangulation[ Array[{Random[], Random[]} &, n]]; Which[edm === Random, DeleteRandomEdges[g, Random[Integer, {1, Length[Edges[g]]}]], Head[edm] === DeleteEdges, DeleteRandomEdges[g, mmm=Min[edm[[1]], Length[EdgeSet[g]]]], True, Message[sdfgsdg]; Return[hf]]] Options[ShowColoredGraph] = { VertexColors -> Automatic, EdgeStyle -> {}, HighlightNeighbors -> {}, Normalized->False, Background->GrayLevel[0.55], HighlightEdges->{}, HighlightStyle -> {Thickness[0.008]}, Labels->False, LabelOffset -> -0.05, AspectRatio->Automatic, Frame->True, VertexSize -> Automatic}; ShowColoredGraph[Graph[am_, v_], coloring1_List:{None}, opts___] := Module[ {cols, esty, vsize, labQ, bg, frQ, normQ,pp,vv, hn, he}, {cols, esty, vsize, labQ, bg, frQ, normQ, asp, laboff, hn, he, hsty} = {VertexColors, EdgeStyle, VertexSize, Labels, Background, Frame, Normalized, AspectRatio, LabelOffset, HighlightNeighbors, HighlightEdges, HighlightStyle} /. {opts} /. Options[ShowColoredGraph]; If[!ListQ[hn], hn = {hn}]; If[!ListQ[hsty], hsty = {hsty}]; edg = Complement[EdgeSet[Graph[am,v]], Sort /@ he]; g1 = If[normQ, NormalizeVertices, Identity][Graph[am, v]]; vv = Vertices[g1]; vsize = vsize /. Automatic -> PointSize[Which[ Length[v] <= 12, 0.035, Length[v] <= 25, 0.022, Length[v] <= 100, 0.018, True, 0.01]]; cols = cols /. Automatic -> NiceColorSet; coloring = coloring1 /. {None} -> Array[1&, Length[vv]]; esty = Flatten[{esty}]; If[!ListQ[laboff], laboff = (laboff& /@ vv)]; Show[Graphics[{ Join[esty, Line[v[[#]]]& /@ edg], Join[hsty, Line[v[[#]]]& /@ he], {Thickness[0.015], Function[m, Line[v[[{#, m}]]]& /@ Neighbors[Graph[am,v],m]] /@ hn}, vsize, Transpose[{cols[[coloring]], Point /@ vv}], If[labQ =!= False, MapIndexed[Text[ If[labQ === True, ToString[#2[[1]]], ToString@labQ[[#2[[1]]]]], #1 + laboff[[#2[[1]]]]]&, vv], {}]}], Background->bg, Frame->frQ, FilterOptions[Graphics, opts], AspectRatio -> asp, FrameTicks->False, del = 0.1; PlotRange -> (xmin = Min[Map[First,vv]]; xmax = Max[Map[First,vv]]; ymin = Min[Map[Last,vv]]; ymax = Max[Map[Last,vv]]; {{xmin - del Max[1,xmax-xmin], xmax + del Max[1,xmax-xmin]}, {ymin - del Max[1,ymax-ymin], ymax + del Max[1,ymax-ymin]} } ) ]] K = CompleteGraph; DegreeSequenceOrdered[Graph[am_, _]] := Count[#, 1] & /@ am MaxDegree[g_Graph] := First[DegreeSequence[g]] MinDegree[g_Graph] := Last[DegreeSequence[g]] MinDegreeVertices[g_Graph] := Flatten[Position[ DegreeSequenceOrdered[g], MinDegree[g]]] Neighbors[g_Graph,v_Integer] := Flatten[Position[g[[1,v]],1]] Neighbors[g_, v_List] := Union@@(Neighbors[g,#]& /@ v) DeleteEdges[g_, s_] := Fold[DeleteEdge, g, s] AddEdges[g_, s_List] := Fold[AddEdge, g, s] AddVertexAndEdges[g_Graph, s_, place_]:= ReplacePart[ AddEdges[AddVertex[g], {1+V[g],#}& /@ s], place, {{-1,-1}}] AddVertexAndEdges[g_Graph, s_]:= AddEdges[AddVertex[g], {1 + V[g], #} & /@ s] FiveColoring[g_Graph] := {1} /; V[g] == 1 FiveColoring[g_Graph] := Module[{ fc, hf = HoldForm[FiveColoring[g]], new, nbrs, min, vert, g1, pair, pairs}, min = MinDegree[g]; If[min > 5, Message[FiveColoring::nonpln]; Return[hf]]; vert = First[MinDegreeVertices[g]]; nbrs = Neighbors[g, vert]; g1 = DeleteVertex[g, vert]; nbrsInDel = nbrs /. n_?(# > vert &) :> n - 1; If[min <= 4, fc = Check[FiveColoring[g1], Return[hf]], pairs = Select[KSubsets[nbrsInDel, 2], g[[1, #1[[1]], #1[[2]]]] == 0 &]; If[pairs == {}, Message[FiveColoring::hasK6]; Return[hf]]; pair = First[pairs]; fc = Check[FiveColoring[DeleteVertex[DeleteVertex[AddVertex[g1, Union[Neighbors[pair[[1]]], Neighbors[pair[[2]]]]], pair[[1]]], pair[[2]]]]]; fc = Drop[Insert[fc, Last[fc], pair], -1], Return[hf]]; fc = Insert[fc, new, vert]; new = First[Complement[Range[5], fc[[nbrs]]]]; fc] /; V[g] > 1 posn[m_, g_, v_Integer] := First[First[ Position[N[m][[2]], N[g[[2,v]]] ] ]] (* xxx My return hfs...may not be working properly!!! Use Check to return the large hf....or have FiveColoring Check[] *) SignedArea[{{x1_,y1_}, {x2_,y2_}, {x3_,y3_}}] := SACom[x1, y1, x2, y2, x3, y3] SACom = Compile[{x1, y1, x2, y2, x3, y3}, 0.5(-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3)]; SignedArea[polygon_] := Plus @@ Flatten[ polygon * Map[{1,-1} * Reverse[#] &, RotateLeft[polygon]]]/2 /; Length[polygon] > 3 Area[poly_] := Abs[SignedArea[poly]] Orientation[{{x1_,y1_}, {x2_,y2_}, {x3_,y3_}}] := Sign[Chop[Det[{{x1,y1,1}, {x2,y2,1}, {x3,y3,1}}]]] ConvexVertex[p_]:=First[First[Position[p,First[Sort[p]]]]] Orientation[poly_]:= Orientation[ poly[[ConvexVertex[poly]+{-1,0,1}/.{ 0->Length[poly],Length[poly]+1->1} ]]]/;Length[poly]>3 LeftOf[p_, q_, r_] := Orientation[{p, q, r}] == 1 RightOf[p_, q_, r_] := Orientation[{p, q, r}] == -1 Leftmost[polygon_] := First@First@Position[polygon, First[Sort[polygon]]] ConvexVertex[polygon_, i_] := Module[{n = Length[polygon]}, Orientation[polygon[[i + Range[-1, 1] /. {0 -> n, n + 1 -> 1}]]] == 1] ConvexVertexNonStrict[polygon_, i_] := Module[{n = Length[polygon]}, Orientation[polygon[[i + Range[-1, 1] /. {0 -> n, n + 1 -> 1}]]] != -1] Orientation[polygon_] := Module[ {n = Length[polygon]}, Orientation[ polygon[[Leftmost[polygon] + {-1,0,1} /. {0 -> n, n+1 -> 1}]]]] /; Length[polygon] > 3 Norm[v_] := N[Sqrt[v . v]] Between[p_,q_,r_]:= Orientation[{p,q,r}]==0 && If[p[[1]] != r[[1]], p[[1]] <= r[[1]] <= q[[1]] || q[[1]] <= r[[1]] <= p[[1]], p[[2]] <= r[[2]] <= q[[2]] || q[[2]] <= r[[2]] <= p[[2]]] Intersect[{a_, b_}, {c_, d_}] := (( Xor[LeftOf[a, b, c], LeftOf[a, b, d]] && Xor[LeftOf[c, d, a], LeftOf[c, d, b]]) || (Between[a, b, c] || Between[a, b, d] || Between[c, d, a] || Between[c, d, b] )) && (a != c || (Between[a,b,d] || Between[a,d,b])) && (a != d || (Between[a,b,c] || Between[a,c,b])) && (b != c || (Between[b,a,d] || Between[b,d,a])) && (b != d || (Between[b,a,c] || Between[b,c,a])) SegmentIntersection[ {{a_, b_}, {c_, d_}}, {{e_, f_}, {g_, h_}}] := {b*c*e - a*d*e - b*c*g + a*d*g - a*f*g + c*f*g + a*e*h - c*e*h, b*c*f - a*d*f - b*f*g + d*f*g - b*c*h + a*d*h + b*e*h - d*e*h}/ (b*e - d*e - a*f + c*f - b*g + d*g + a*h - c*h) NormSq[p_]:=p.p IntersectClosed[{a_,b_},{c_,d_}]:= IntersectOpen[{a,b},{c,d}] || Between[a,b,c] || Between[a,b,d] || Between[c,d,a] || Between[c,d,b] MakeCounterclockwise[polygon_] := If[Orientation[polygon] == -1, Reverse, Identity][polygon] ConvexVertex[polygon_] := Module[{i = 2}, While[ !ConvexVertex[polygon, i], i++]; i] Inside[{p_, q_, r_}, point_] := !LeftOf[q, p, point] && !LeftOf[r, q, point] && !LeftOf[p, r, point] PolygonDiagonal[polygon_] := Module[ {i = ConvexVertex[polygon], invertices}, invertices = Select[Drop[polygon, {i - 1, i + 1}], Inside[polygon[[{i - 1, i, i + 1}]], #1] & ]; If[invertices == {}, {i - 1, i + 1}, Prepend[Flatten[Position[polygon, Last[Sort[invertices, SignedArea[ {polygon[[i - 1]], #1, polygon[[i + 1]]}] <= SignedArea[{polygon[[i-1]], #2, polygon[[i+1]]}] & ]]]], i]]] Triangulate[polygon_] := (flipped = (Orientation[polygon] == -1); mainPoly = (func = If[flipped, Reverse, Identity])[polygon]; func /@ TriangulateSinglePoly[Range[Length[polygon]]]) TriangulateSinglePoly[vlabs_] := {vlabs} /; Length[vlabs] == 3 && IntegerQ[vlabs[[1]]] TriangulateSinglePoly[vlabs_] := Module[{diag, diag1,poly1, poly2}, diag = vlabs[[diag1=PolygonDiagonal[mainPoly[[vlabs]]]]]; poly1 = Take[vlabs, diag1]; poly2 = Drop[vlabs, {1 + diag1[[1]], diag1[[2]] - 1}]; Join[TriangulateSinglePoly[poly1], TriangulateSinglePoly[poly2]]] /; Length[vlabs] > 3 && IntegerQ[vlabs[[1]]] extend[l_] := Append[l, First[l]]; join[{n_, l_}] := (Join[{n}, #1] & ) /@ l canon[l_] := RotateLeft[l, First[Flatten[Position[l, Min[l]]]]-1] edges[l_] := Partition[extend[l], 2, 1] edgesSorted[l_] := Sort /@ Partition[extend[l], 2, 1] adjacent[face1_, face2_] := If[face1 =!= face2 && (Intersection @@ (edgesSorted /@ {face1, face2}) )!= {}, 1, 0] Centroid[poly_] := Plus @@ poly / Length[poly] (* following finds largest triangle, assuming counterclockwise; though Centroid is used in convex case *) ConvexQ[pts_] := Range[Length[pts]] == canon@ConvexHull[pts] centroidFalse[poly_] := Module[{ars, tris}, If[ConvexQ[poly], Centroid[poly], tris = (MakeCounterclockwise[poly][[#]]&) /@ Triangulate[ MakeCounterclockwise[poly]]; ars = SignedArea /@ tris; Centroid @ First[tris[[Flatten @ Position[ars, Max[ars]]]]]]] Options[ShowMap] = { Borders -> True, BorderPoints -> True, BorderPointStyle->Automatic, Background -> RGBColor[0.2, 0.8, 1], DefaultColor -> GrayLevel[0], PlotLabel->None, ColorOutput -> Automatic, ShowEulerFormulaData -> False, Frame->True, FrameStyle -> {GrayLevel[0], AbsoluteThickness[3]}, BorderStyle -> {GrayLevel[0]}, ShowVertexFaceEdgeData -> False, VertexSize -> PointSize[0.021], CountryColors->Automatic, ShowAdjacencyGraph -> False, FontSize -> 12, FourColorCountries->False}; ShowMap[PlanarMap[faceindices_, pts_], opts___] := Module[{oc,borptsQ, borQ, borsty, pl, lab1Q,lab2Q,map, i = 0, lab, nborders, actualfaces, nfaces, xmin, xmax, ymin, ymax, pr, planQ, try4colQ, del2, graphOfMap, hf = HoldForm[RandomPlanarMap[n,opts]]}, {oc,frQ, fsty,borptsQ, borQ, borsty, pl, lab1Q, lab2Q, cols, psty, planQ, try4colQ, vsize, grQ, fs} = {Background, Frame, FrameStyle,BorderPoints, Borders, BorderStyle, PlotLabel, ShowEulerFormulaData, ShowVertexFaceEdgeData, CountryColors, BorderPointStyle, ShowAdjacencyGraph, FourColorCountries, VertexSize, ColorOutput, FontSize} /.{opts} /. Options[ShowMap]; If[cols === Automatic, cols = NiceColorSet]; If[lab1Q, lab2Q = False]; nborders = Length[pts]; If[!ListQ[psty], psty = {psty}]; psty = psty /. Automatic -> PointSize[Which[ nborders <= 12, 0.035, nborders <= 25, 0.022, True, 0.014]]; If[!ListQ[fsty], fsty = {fsty}]; If[borptsQ === None, borptsQ = False]; If[!ListQ[borsty], borsty = {borsty}]; If[FreeQ[psty, PointSize | AbsolutePointSize], PrependTo[psty, PointSize[0.025]]]; actualfaces = pts[[#]]& /@ faceindices; If[planQ || try4colQ, graphOfMap = AdjacencyGraph[PlanarMap[faceindices, pts], FilterOptions[AdjacencyGraph, opts]]]; nfaces = Length[faceindices] + 1; If[MemberQ[{RGBColor, Hue, GrayLevel}, Head[cols]], cols = Array[cols&, nfaces]]; lab = If[lab1Q, ShowTableGC[{ {nborders, (((Plus @@ Length /@ faceindices))+ Length@Boundary[PlanarMap[faceindices, pts]])/2, nfaces, DisplayForm[StyleBox["2", FontColor-> If[grQ === GrayLevel, Black, Red], FontWeight -> Bold]]}}, ColumnAlignments -> Center, HeadingFontSize -> fs, Background -> If[grQ === GrayLevel, White, RGBColor[1,1,.6]], RowSpacings -> 1.5, ColumnSpacings -> 0.5, GridFrameMargins -> {{0.2, 0.2}, {0.5, 1.1}}, FontSize -> fs, FontFamily -> "Times", HeadingFontColor -> Red, ColumnHeadings -> {"Vertices", "Edges", " Faces\n(including exterior)", "V\[ThinSpace]-\[ThinSpace]E\[ThinSpace]+\[ThinSpace]F"}], pl]; If[lab2Q, lab = ShowTableGC[{ {nborders, (((Plus @@ Length /@ faceindices))+ Length@Boundary[PlanarMap[faceindices, pts]])/2, nfaces}}, ColumnAlignments -> Center, HeadingFontSize -> fs, RowSpacings -> 1.5, ColumnSpacings -> 0.5, GridFrameMargins -> {{0.2, 0.2}, {0.5, 1.1}}, FontSize -> fs, Background -> If[grQ === GrayLevel, White, RGBColor[1,1,.6]], FontFamily -> "Times", HeadingFontColor -> If[grQ === GrayLevel, Black, Red], ColumnHeadings -> {"Vertices", "Edges", "Faces (including exterior)"}]]; If[try4colQ , cols = cols[[FourColoringPL[graphOfMap, FilterOptions[FourColoring,opts]]]]]; del2 = 0.05; map = Join[borsty, {{Which[cols === Automatic && !try4colQ, Hue[i++/(nfaces - 1)]; NiceColorSet[[++i]], try4colQ, cols[[++i]], True, cols[[++i]]], Polygon[#]}, If[borQ, Line[extend[#]],{}]}& /@ actualfaces]; xmin = Min[Map[First,pts]]; xmax = Max[Map[First,pts]]; ymin = Min[Map[Last,pts]]; ymax = Max[Map[Last,pts]]; pr = { {xmin - del2 Max[1,xmax-xmin], xmax + del2 Max[1,xmax-xmin]}, {ymin - del2 Max[1,ymax-ymin], ymax + del2 Max[1,ymax-ymin]} }; Show[Graphics[{ {oc /. None|False->GrayLevel[1], Rectangle @@ Transpose[pr]}, If[frQ === True, Append[fsty, Line[extend[{First /@ pr, {pr[[1,2]], pr[[2,1]]}, Last /@ pr, {pr[[1,1]], pr[[2,2]]}}]]],{}], map, Join[psty, If[borptsQ, Point /@ pts, {}]]}], If[planQ, ShowGraph[graphOfMap, Normalized->False, DisplayFunction->Identity, FilterOptions[ShowGraph,{opts}]],{}], PlotLabel -> lab, Evaluate[FilterOptions[Graphics, opts]], PlotRange -> pr, Frame->!True, FrameStyle -> {}, AspectRatio -> Automatic, FrameTicks->None]] mod5Fix[index_] := Mod[index, 5] /. 0->5 (* Following generates a random permutation with some fix nonprecolored vertices. It is used to permute only nonprecolored vertices. *) ranpermfix[n_, l_] := Module[ {i=Complement[Range[n], l][[RandomPermutation[n - Length[l]]]]}, Scan[(i = Insert[i, #, #])&, l]; i] Options[FourColoring] = {Precolored -> {}, KittellTrace ->False, PlanarCheck -> False, MaxTries->100, Method -> Kempe, AlgorithmTrace -> False, PrintTraceData -> False, TraceIncrement->10, Randomize->False}; FourColoring[g_Graph, opts___] := {1} /; V[g] == 1 FourColoring[g_Graph, opts___] := Module[{pp, met, ans, traceQ, pre, ranQ, ran, hf}, {met, traceQ, pre, planck, td, ranQ} = {Method, AlgorithmTrace, Precolored, PlanarCheck, PrintTraceData, Randomize} /. {opts} /. Options[FourColoring]; hf = Shallow[HoldForm[FourColoring[g,opts]],6]; ran = If[ranQ && (met =!= Brelaz), ranpermfix[V[g], First /@ pre], Range[V[g]]]; main = If[ranQ && (met =!= Brelaz), PermuteLabels[g, ran], g]; If[pre != {} && !(ListQ[pre] && (And@@( (ListQ[#] && Union[Head /@ #] == {Integer} &) /@ pre))), Message[FourColoring::badpre]; Return[HoldForm[FourColoring[g,opts]]]]; If[met === Brelaz && pre =!= {}, Message[FourColoring::incon]; Return[hf]]; If[met === Brelaz, ans = VertexColoring[g]; If[Max[ans] > 4, Message[FourColoring::fail, Max[ans]]; Return[hf], Return[ans]]]; If[traceQ, tracecols = Array[5&, V[g]]; Scan[(tracecols = ReplacePart[tracecols, #[[2]], #[[1]]])&, pre]; SetOptions[ShowColoredGraph, VertexSize -> AbsolutePointSize[24], Normalized -> False, VertexColors -> SoftColorsPlus[GrayLevel[0.7]]]; SetOptions[Graphics,FrameStyle->AbsoluteThickness[2.5], DefaultFont -> {"Courier-Bold", If[V[g] > 9, 14, 18]}]; labs = MapIndexed[Text[#2[[1]], #1] & , g[[2]]]; del = 0.12; xmin = Min[First /@ g[[2]]]; xmax = Max[First /@ g[[2]]]; ymin = Min[Last /@ g[[2]]]; ymax = Max[Last /@ g[[2]]]; pr = {{xmin - del*Max[1, xmax - xmin], xmax + del*Max[1, xmax - xmin]}, {ymin - del*Max[1, ymax - ymin], ymax + del*Max[1, ymax - ymin]}}]; If[traceQ, ShowColoredGraph[main, tracecols, Epilog -> labs, PlotRange -> pr]]; If[planck && !PlanarEmbeddingQ[g], Message[FourColoring::nonplnar]; Return[[hf]]]; If[Length[pre] < V[g], Check[ans = FourColoringNonRecursive[main, KempeOrder[main, First /@ pre], opts], Return[hf]], ans = Last /@ pre]; ans = ans[[InversePermutation[ran]]]; If[traceQ, If[Length[pre] < V[g], ShowColoredGraph[g, ans, PlotRange -> pr, Epilog -> labs]]; SetOptions[Graphics, FrameStyle -> {}, DefaultFont -> $DefaultFont, PlotRange -> Automatic]; SetOptions[ShowColoredGraph, VertexColors->Automatic, Normalized->False, VertexSize->Automatic]]; ans] /; V[g] > 1 SoftColorsPlus[c_:GrayLevel[1]] := { RGBColor[1, 0.05, 0.3], RGBColor[0.4, 1, 0.4], RGBColor[.1,.7,1], RGBColor[1, 1, 0.5], c}; (* Red, Green, Blue, Yellow *) K4MapInPlane = Module[{sm, c}, sm = (c = {1/2, Sqrt[3]/6}) + 1/2(# -c)& /@ {{0,0}, {1,0},{1/2, Sqrt[3]/2}}//N; PlanarMap[{{1,2,3,4},{1,6,5,2},{6,4,3,5},{2,5,3}}, {{0,0}, sm[[1]], sm[[3]], {0.5, Sqrt[3]/2}, sm[[2]], {1,0}}]]; (* This overwrites Combinatorica's ShowGraph and ShowLabeledGraph so they accept graphics options, and Normailized option *) Unprotect[ShowGraph, ShowLabeledGraph]; Clear[ShowGraph, ShowLabeledGraph]; (* important *) Options[ShowGraph] = {Normalized -> False, EdgeStyle -> {}, VertexColor -> GrayLevel[0], VertexSize -> Automatic}; Options[ShowLabeledGraph] = {Normalized->False, EdgeStyle->{}, VertexColor -> GrayLevel[0], VertexSize -> Automatic, LabelOffset -> -0.05}; ShowGraph[g_PlanarGraph, opts___] := ShowGraph[Graph @@ g, opts] ShowLabeledGraph[g_PlanarGraph, opts___] := ShowLabeledGraph[Graph @@ g, opts] ShowGraph[g1_Graph,type_Symbol:Undirected, opts___Rule] := Module[{g, esty, vcol, vsize, pts, lines}, {esty,normalQ, vcol, vsize} = {EdgeStyle, Normalized, VertexColor, VertexSize} /. {opts} /. Options[ShowGraph]; If[!ListQ[esty], esty = {esty}]; g = If[normalQ, NormalizeVertices,Identity][g1]; pts = Point /@ g[[2]]; lines = Line[g[[2,#]]]& /@ EdgeSet[g]; vsize = vsize /. Automatic -> PointSize[Which[ V[g1] <= 12, 0.035, V[g1] <= 25, 0.022, V[g1] <= 100, 0.018, True, 0.01]]; Show[Graphics[{ Join[esty, lines], Join[{vcol,vsize}, pts], If[SameQ[type,Directed],Arrows[g],{}]}], FilterOptions[Graphics, opts], AspectRatio -> Automatic, PlotRange-> DiscreteMath`Combinatorica`Private`FindPlotRange[Vertices[g]] ]] ShowLabeledGraph[g_Graph, opts___Rule] := ShowLabeledGraph[g, Range[V[g]], opts] ShowLabeledGraph[g1_Graph, labels_List, opts___Rule] := Module[{vsize, vcol, pts, lines, laboff, esty, pairs = ToOrderedPairs[g1], g, v}, {esty, normalQ, vsize, vcol, laboff} = {EdgeStyle, Normalized, VertexSize, VertexColor, LabelOffset} /. {opts} /. Options[ShowLabeledGraph]; If[!ListQ[esty], esty = {esty}]; vsize = vsize /. Automatic -> PointSize[Which[ V[g1] <= 12, 0.035, V[g1] <= 25, 0.022, V[g1] <= 100, 0.018, True, 0.01]]; del = 0.18; g =If[normalQ, NormalizeVertices,Identity][g1]; v = Vertices[g]; xmin = Min[First /@ v]; xmax = Max[First /@ v]; ymin = Min[Last /@ v]; ymax = Max[Last /@ v]; pr = {{xmin - del*Max[1, xmax - xmin], xmax + del*Max[1, xmax - xmin]}, {ymin - del*Max[1, ymax - ymin], ymax + del*Max[1, ymax - ymin]}}; pts = Point /@ g[[2]]; lines = Line[g[[2,#]]]& /@ EdgeSet[g]; Show[Graphics[{ Join[esty, lines], Join[{vsize, vcol}, pts], GraphLabels1[v, labels, laboff]}], FilterOptions[Graphics, opts], AspectRatio->Automatic, PlotRange->pr]] Protect[ShowGraph, ShowLabeledGraph]; Options[ShowToroidalGraph] = {Background -> GrayLevel[0.7], EdgeStyle->{}, IdentificationArrows -> True, Labels -> False, LabelOffset -> -0.03, TorusRange -> {2,1}, SpecialEdgeStyle -> {}, FrameStyle -> AbsoluteThickness[4], VertexStyle -> {PointSize[0.03]}}; ShowToroidalGraph[Graph[am_, v_], spec_, opts___] := Module[{xx,x1,y1,bac,fsty,esty, arrQ }, {vsty, labQ, laboff, tr, spsty, bac, fsty,esty, arrQ} = {VertexStyle, Labels, LabelOffset, TorusRange, SpecialEdgeStyle, Background, FrameStyle, EdgeStyle, IdentificationArrows} /. {opts} /. Options[ShowToroidalGraph]; {x1, y1} = tr; {vsty, fsty, spsty, esty} = Map[If[!ListQ[#],{#},#]&, {vsty, fsty, spsty,esty}]; If[!ListQ[laboff], laboff = (laboff& /@ v)]; special = spec /. {x_Integer, y_Integer, s_Symbol} :> {x,y,s,{}}; special = Transpose[ Append[Transpose[special][[{1,2,3}]], Flatten /@ List /@ Transpose[special][[-1]]]]; Show[Graphics[{ {bac, Rectangle[{0,0},{x1,y1}]}, Join[esty, (Line[v[[#1]]]&) /@ Complement[EdgeSet[Graph[am, v]], (Sort[Drop[#1, -2]] & ) /@ special], Join[spsty, (Append[#[[4]], Line[{v[[#[[1]]]], #[[3]]+ v[[#[[2]]]]}]] & ) /@ (special /. {Up -> {0, y1}, Down -> {0, -y1}, Left -> {-x1, 0}, Right -> {x1, 0}}) /. {(Line[{p_, q_}] /; q[[1]] > x1 :> (xx = SegmentIntersection[{p, q}, {{x1, 0}, {x1, y1}}][[2]]; Line /@ {{p, {x1,xx}}, {q - {x1,0}, {0,xx}}})), (Line[{p_, q_}] /; q[[1]] < 0 :> (xx = SegmentIntersection[{p, q}, {{0, 0}, {0, y1}}][[2]]; Line /@ {{p, {0,xx}}, {q + {x1,0}, {x1,xx}}})), (Line[{p_, q_}] /; q[[2]] < 0 :> (xx = SegmentIntersection[{p, q}, {{0, 0}, {x1, 0}}][[1]]; Line /@ {{p, {xx, 0}}, {q + {0, y1}, {xx, y1}}})), (Line[{p_, q_}] /; q[[2]] > y1 :> (xx = SegmentIntersection[{p, q}, {{0, y1}, {x1, y1}}][[1]]; Line /@ {{p, {xx, 1}}, {q - {0, y1}, {xx, 0}}}))}]], Join[{PointSize[0.03]}, vsty, Point /@ v], If[labQ =!= False, MapIndexed[Text[ If[labQ === True, ToString[#2[[1]]], ToString@labQ[[#2[[1]]]]], # + laboff[[#2[[1]]]]]&, v], {}], Append[fsty,Line[{{0,0}, {x1,0}, {x1,y1},{0,y1},{0,0} }]], If[arrQ,{{Blue, Polygon /@ {{{0, y1/2 + (d = .025 x1)},{d,y1/2-d},{-d,y1/2-d}}, {{x1, y1/2+d},{x1 +d,y1/2-d},{x1 -d,y1/2-d}}}}, {Green, Polygon /@ {r = x1/y1; d = 0.025 y1 r; {{x1/2, y1}, {x1/2 - r d, y1+d}, {x1/2- r d, y1-d}}, {{x1/2, 0}, {x1/2-r d, d}, {x1/2-r d, -d}}}}},{}] }], Background->None, FilterOptions[Graphics, opts], DefaultFont -> {"Courier", 12}, AspectRatio -> Automatic, PlotRange -> {{-0.05 x1, x1 1.05}, {-0.05 y1, y1 1.05}}]] GraphLabels1[v_List, l_List, off_:(-0.05)] := Module[{offsets}, offsets = If[NumberQ[off], {off, off} & /@ l, off]; Table[Text[l[[i]], v[[i]] + offsets[[i]]], {i, Length[v]}]] (* this first creates a random triangulation, then uses the centroids of the triangles to form regions *) RandomPlanarMap[n_Integer] := Module[{index, ans, pts, uu, actualfaces, dt, interior, conn = False, hf = HoldForm[RandomPlanarMap[n]]}, index[face_] := Flatten[Position[borderpts, #] & /@ face]; If[n < 4, Message[RandomPlanarMap::badarg]; Return[hf]]; interior = {}; While[interior == {} || !conn, pts = Array[{Random[], Random[]} & , n]; dt = DelaunayTriangulation[pts]; uu = Union[canon /@ Flatten[(join[{#1[[1]], Partition[#1[[2]], 2, 1]}] & ) /@ dt, 1]]; interior = Complement[Range[n], ConvexHull[pts]]; actualfaces = Table[MakePointsCounterclockwise[ (Centroid[pts[[#]]]&) /@ Select[uu, MemberQ[#, interior[[i]]] &], pts[[interior[[i]]]]], {i, Length[interior]}]; borderpts = Union[Flatten[actualfaces, 1]]; ans = PlanarMap[index /@ actualfaces, borderpts]; conn = ConnectedQ[ans]]; ans]; Options[StraightLineAdjacencyGraph] = {PlanarCheck->False}; StraightLineAdjacencyGraph[PlanarMap[faces_, pts_], opts___] := Module[{pcQ, g, hf = HoldForm[StraightLineAdjacencyGraph[PlanarMap[faces, pts, opts]]]}, pcQ = PlanarCheck /. {opts} /. Options[StraightLineAdjacencyGraph]; g = PlanarGraph[Outer[adjacent, faces, faces, 1], centroidFalse[pts[[#]]]& /@ faces]; If[!pcQ, Return[g], If[PlanarEmbeddingQ[Graph @@ g], g, Message[StraightLineAdjacencyGraph::cnvltd]; Return[hf]]]] PlanarMapToGraphOfMap[PlanarMap[faces_, pts_]] := Module[{nbrs}, nbrs[i_] := (goodfaces = Select[faces, MemberQ[#, i]&]; Union@Flatten[( #[[First@ Flatten[ Position[#, i] ]+{1,-1} /. {0 -> -1,Length[#]+1->1}]])& /@ goodfaces]); PlanarGraph[FromAdjacencyLists[ Map[nbrs, Range[Length[pts]]]][[1]],pts]] PermuteLabels[(g_Graph) | (g_PlanarGraph), perm_] := Head[g][First@ FromAdjacencyLists[ ToAdjacencyLists[g][[perm]] /. Thread[Range[V[g]] -> InversePermutation[perm]]], g[[2, perm]]] RandomLabeling[g_PlanarGraph] := PlanarGraph@@ RandomLabeling[Graph@@g] RandomLabeling[g_Graph] := PermuteLabels[g, RandomPermutation[V[g]]] EulerFormulaProofGraphs[m_PlanarMap, ocean_:RGBColor[0, .749, 1]] := Module[ {ans, gr = PlanarMapToGraphOfMap[m], cols = Take[NiceColorSet, {8, 8+NFaces[m]-1}]}, ans = {{cols, gr}}; While[!TreeQ[gr], gr = DeleteEdge[gr, edge = First[Partition[FindCycle[gr], 2, 1] ]]; fac = Select[Range[NFaces[m]], MemberQ[Sort /@ Partition[extend[m[[1, #]]], 2, 1], Sort[edge]]&]; cols = If[Length[fac] == 1, cols /. cols[[fac[[1]]]] -> ocean, Which[ cols[[fac[[1]]]] === ocean, cols /. cols[[fac[[2]]]] -> ocean, cols[[fac[[2]]]] === ocean, cols /. cols[[fac[[1]]]] -> ocean, True, cols /. (rule= cols[[fac[[1]]]] -> cols[[fac[[2]]]])]]; ans = Flatten[{ans, {{cols, gr}}}, 1]]; While[V[gr] > 1, gr = DeleteVertex[gr, First[First[ Position[DegreeSequenceOrdered[gr], 1]]]]; ans = Flatten[{ans, {{cols, gr}}}, 1]]; ans] Options[EulerFormulaProofMovie] = {ShowVertexFaceEdgeData -> True, ColorOutput->Automatic, FontSize -> 12, Background -> RGBColor[0, .749,1]}; EulerFormulaProofMovie[m_PlanarMap, opts___] := Module[{labQ}, {co,labQ, ocean, fs} = {ColorOutput, ShowVertexFaceEdgeData, Background, FontSize} /. {opts} /. Options[EulerFormulaProofMovie]; Map[Show[ ShowMap[m, FilterOptions[ShowMap, opts], DisplayFunction -> Identity, Borders -> False, BorderPoints -> False, CountryColors -> #[[1]], Background -> ocean], ShowGraph[#[[2]], Normalized -> False, EdgeStyle -> AbsoluteThickness[2.5], DisplayFunction -> Identity, VertexSize -> PointSize[0.04]], FilterOptions[Graphics, opts], DisplayFunction -> $DisplayFunction, PlotLabel -> If[labQ, DisplayForm[ShowTableGC[{{V[#1[[2]]], M[#1[[2]]], -V[#1[[2]]] + M[#1[[2]]] + 2}}, ColumnAlignments -> Center, HeadingFontSize -> fs, RowSpacings -> 1.5, ColumnSpacings -> 0.5, GridFrameMargins -> {{0.2, 0.2}, {0.5, 1.1}}, FontSize -> fs, FontFamily -> "Times", HeadingFontColor -> If[co===GrayLevel,Black,Red], Background->If[co===GrayLevel, GrayLevel[1], RGBColor[1,1,.7], GrayLevel[1]], ColumnHeadings -> {"Vertices", "Edges", " Faces\n(including exterior)"}] ], None], Background->None] &, EulerFormulaProofGraphs[m, ocean]]] K4Planar = StraightLineAdjacencyGraph[K4MapInPlane]; IcosahedralGraph = PlanarGraph[ First[FromAdjacencyLists[{{2,3,4,5,6},{1,3,6,10,11}, {1,2,4,9,10},{1,3,5,8,9},{1,4,6,7,8}, {1,2,5,7,11}, {5,6,8,11,12},{4,5,7,9,12}, {3,4,8,10,12}, {2,3,9,11,12},{2,6,7,10,12}, {7,8,9,10,11 }}]], {{3,9},{-4,0},{10,0},{5,5},{3,6},{1,5},{2,4}, {4,4},{5,2},{3,1},{1,2},{3,3}}]; GasWaterElectricityDiagram := (del = 0.14; ShowGraph[g = RotateVertices[K[3, 3], Pi/2], VertexStyle -> {Black, AbsolutePointSize[6]}, EdgeStyle -> {AbsoluteThickness[2], Magenta}, PlotRange -> {{-1.2, 1.4}, {0.7, 2.3}}, Frame -> True, Background -> Cyan, FrameTicks -> False, Normalized -> False, Epilog -> {Text["Gas", g[[2,6]] + {0, del}], Text["Water", g[[2,5]] + {0, del}], Text["Electricity", g[[2,4]] + {0, del}], Text["A", g[[2,3]] - {0, del}], Text["B", g[[2,2]] - {0, del}], Text["C", g[[2,1]] - {0, del}]}, DefaultFont -> {"Courier", 12}, DefaultColor -> Black]) KempeExamples[1] = {PlanarGraph[{{0,1,0,1,0,0,0,0,1,0,0,1,0,0,1},{1,0,1,0,0,1,1,0,1,1,0,0,0,1,1},{0,1,0,1,0,1,0,0,0,0,0,0,0,0,1},{1,0,1,0,0,0,1,1,0,0,0,1,0,0,1}, {0,0,0,0,0,0,1,0,0,1,0,0,0,0,0},{0,1,1,0,0,0,1,0,0,0,0,0,0,0,0}, {0,1,0,1,1,1,0,1,0,0,0,0,1,0,0},{0,0,0,1,0,0,1,0,0,0,0,0,0,0,0}, {1,1,0,0,0,0,0,0,0,1,0,0,0,0,0},{0,1,0,0,1,0,0,0,1,0,1,0,0,1,0}, {0,0,0,0,0,0,0,0,0,1,0,0,1,0,0}, {1,0,0,1,0,0,0,0,0,0,0,0,0,0,0},{0,0,0,0,0,0,1,0,0,0,1,0,0,0,0},{0,1,0,0,0,0,0,0,0,1,0,0,0,0,0},{1,1,1,1,0,0,0,0,0,0,0,0,0,0,0}}, {{0,-1},{1.2,-0.2},{-0.2,0.7}, {-1,0.3},{1.8,2},{0.45,1.1},{0.7,2}, {-0.9,2},{1.3,-1},{2,0},{1.7,1.3}, {-1,-1},{1.2,1.6},{1.5,0.5},{-0.2,0}}],{3,4,1,2,2,3,1,4,1,3,4,1,2,2,5}}; KempeExamples[2] = {KempeExamples[1][[1]], {3, 4, 1, 2, 2, 3, 1, 4, 1, 3, 1, 1, 3, 2, 5}}; KempeExamples[3] = {PlanarGraph[mat = FromAdjacencyLists[{{5, 26, 29}, {3, 25, 24, 29}, {2, 4, 6, 11, 29}, {3, 5, 11, 12, 29}, {22, 29}, {7, 15, 16, 23}, {8, 17, 18}, {9, 19, 20}, {10, 21, 22}, {}, {13, 16}, {14}, {18}, {9}, {}, {}, {}, {}, {}, {}, {}, {}, {24}, {}, {}, {27}, {28}, {5, 10}, {}}][[1]]; Sign[mat + Transpose[mat]], {{0.76465199, 1.72080}, {0.0389986, 1.69519}, {-0.182965, 1.35370}, {0.525612, 0.764651}, {1.22565, 1.15735}, {-0.780562, 0.0560729}, {-0.447616, -0.413466}, {0.132906, -0.857395}, {1.08051, -0.720802}, {1.66104, -0.379319}, {0.051594, 0.526510}, {0.89, 0.526510}, {0.25, 0.07}, {0.966225, 0.124965}, {-0.819999, -0.376967}, {-0.23, 0}, {-0.439184, -0.9}, {0.1, -0.3}, {0.65, -1.07966}, {0.63, -0.3}, {1.7, -1}, {1.4, 0}, {-0.85, 1.9}, {-0.48, 1.57054}, {0.398041, 1.91966}, {1.22432, 1.8}, {1.68982, 1.82657}, {2, 0.5}, {0.366951, 1.31342}}], {2, 2, 1, 4, 3, 3, 1, 3, 4, 2, 2, 2, 4, 4, 1, 4, 3, 3, 1, 1, 2, 2, 2, 4, 4, 4, 2, 4, 5}}; KempeExamples[4] = {PlanarGraph[First[FromAdjacencyLists[ {{26, 29, 30}, {3, 24, 25, 30}, {2, 4, 6, 11, 30}, {3, 5, 11, 12, 30}, {4, 22, 26, 28, 29, 30}, {3, 7, 15, 16, 23}, {6, 8, 17, 18}, {7, 9, 19, 20}, {8, 10, 14, 21, 22}, {9, 28}, {3, 4, 13, 16}, {4, 14}, {11, 18}, {9, 12}, {6}, {6, 11, 18}, {7}, {7, 13, 16}, {8}, {8}, {9}, {5, 9}, {6, 24}, {2, 23}, {2, 26}, {1, 5, 25, 27}, {26, 28}, {5, 10, 27}, {1, 5}, {1, 2, 3, 4, 5}}]], {{0.7, 1.8}, {0.0389986, 1.69519}, {-0.182965, 1.35370}, {0.525612, 0.764651}, {1.39999, 0.7}, {-0.780562, 0.0560729}, {-0.447616, -0.413466}, {0.132906, -0.857395}, {1.08051, -0.720802}, {1.66104, -0.379319}, {0.051594, 0.526510}, {0.89, 0.526510}, {0.25, 0.07}, {0.966225, 0.124965}, {-0.819999, -0.376967}, {-0.23, 0}, {-0.439184, -0.901206}, {0.1, -0.3}, {0.65, -1.07966}, {0.629999, -0.3}, {1.7, -1}, {1.39999, 0}, {-0.85, 1.9}, {-0.479999, 1.57054}, {0.398041, 2.1}, {1.22432, 1.8}, {1.68982, 1.82657}, {2, 0.5}, {0.98, 1.35}, {0.366951, 1.31342}}], {2, 1, 2, 4, 3, 4, 1, 4, 1, 2, 3, 1, 4, 4, 1, 2, 3, 3, 1, 1, 2, 2, 1, 4, 3, 1, 2, 4, 4, 5}}; (* ErreraGraph = KempeExamples[5] = KempeCounterexample = PlanarGraph[First[FromAdjacencyLists[{{2, 3, 4, 5, 6}, {1, 3, 6, 7, 8}, {1, 2, 4, 8, 9}, {1, 3, 5, 9, 11}, {1, 4, 6, 10, 11}, {1, 2, 5, 7, 10}, {2, 6, 8, 10, 12, 16}, {2, 3, 7, 9, 12, 13}, {3, 4, 8, 11, 13, 14}, {5, 6, 7, 11, 15, 16}, {4, 5, 9, 10, 14, 15}, {7, 8, 13, 16, 17}, {8, 9, 12, 14, 17}, {9, 11, 13, 15, 17}, {10, 11, 14, 16, 17}, {7, 10, 12, 15, 17}, {12, 13, 14, 15, 16}}]], {{4, 13}, {4, 10.4}, {-0.2, 5}, {-6, -1}, {14, -1}, {8.1, 5}, {4.8, 7.8}, {3.2, 7.8}, {-1.5, 1.6}, {9.5, 1.6}, {4, 0.3}, {4, 6}, {2.7, 5}, {2, 2.2}, {6, 2.2}, {5.3, 5}, {4, 3.6}}]; *) ErreraGraph = KempeExamples[5] = KempeCounterexample = PlanarGraph[{{0,0,1,0,1,0,0,0,0,1,0,1,0,0,0,0,1},{0,0,0,0,0,0,0,1,1,0,0,0,1,1, 1,0,0},{1,0,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0},{0,0,0,0,0,1,0,1,0,0,1,0,1,0, 0,1,0},{1,0,1,0,0,0,0,0,0,0,1,1,0,0,0,1,0},{0,0,0,1,0,0,1,0,0,0,0,0,1,1, 0,1,0},{0,0,0,0,0,1,0,0,1,0,0,1,0,1,0,1,1},{0,1,0,1,0,0,0,0,0,0,1,0,1,0, 1,0,0},{0,1,0,0,0,0,1,0,0,1,0,0,0,1,1,0,1},{1,0,1,0,0,0,0,0,1,0,0,0,0,0, 1,0,1},{0,0,1,1,1,0,0,1,0,0,0,0,0,0,1,1,0},{1,0,0,0,1,0,1,0,0,0,0,0,0,0, 0,1,1},{0,1,0,1,0,1,0,1,0,0,0,0,0,1,0,0,0},{0,1,0,0,0,1,1,0,1,0,0,0,1,0, 0,0,0},{0,1,1,0,0,0,0,1,1,1,1,0,0,0,0,0,0},{0,0,0,1,1,1,1,0,0,0,1,1,0,0, 0,0,0},{1,0,0,0,0,0,1,0,1,1,0,1,0,0,0,0,0}},{{4,13},{4,6},{-0.2,5},{2, 2.2},{-6,-1},{6,2.2},{9.5,1.6},{2.7,5},{4.8,7.8},{4,10.4},{-1.5,1.6},{ 14,-1},{4,3.6},{5.3,5},{3.2,7.8},{4,0.3},{8.1,5}}]; ReducibleExample = Module[{t = 2 Pi/10, sq = Sqrt[3]}, AddEdge[ AddVertexAndEdges[AddVertexAndEdges[ AddVertexAndEdges[ AddVertexAndEdges[ AddVertexAndEdges[Wheel[6], {1,5}, sq{Cos[t],Sin[t]}], {1,2,7}, sq{Cos[3t],Sin[3t]}], {2,3,8}, sq{Cos[5t], Sin[5t]}], {3,4, 9}, sq{Cos[7t], Sin[7t]}], {4,5,10}, sq{Cos[9t], Sin[9t]}], {7,11}]]; MapSmallExample = PlanarMap[{ {1, 3, 5, 2}, {5, 8, 9, 7, 6, 2}, {8, 12, 15, 14, 11, 9}, {4, 10, 12, 8, 5, 3}, {10, 13, 15, 12}, {7, 9, 11}}, {{0.0738, 0.5639}, {0.157, 0.784}, {0.177, 0.4209}, {0.249, 0.2169}, {0.261, 0.641}, {0.268, 0.833}, {0.375, 0.84}, {0.409, 0.583}, {0.412, 0.733}, {0.452, 0.322999}, {0.474, 0.778}, {0.529, 0.4689}, {0.5849, 0.386}, {0.604, 0.68}, {0.662, 0.532}}]; MapOfWesternEurope= PlanarMap[{{13,14,7,3,4},{18,21,17,14,13,4,1,2,6,8,9,16},{26,27,35,40,42,43, 49,41,44,38,37,28,18,16,19,20},{47,45,42,40,35,34,33,39,46,48,54,55, 56,58,53,52},{29,30,26,20,22,15,10,5,11,12,23,24,25},{27,35,34,32,30, 26},{32,30,29,31,36,39,33,34},{58,56,61,60,59,57},{43,45,47,50,49},{ 43,42,45},{47,52,51,50}}, {{-322, 2169}, {-128, 2204}, {-535, 2231}, {-445, 2231}, {964, 2275}, {0, 2317}, {-570, 2323}, {-7, 2336}, {0, 2397}, {940, 2402}, {997, 2406}, {1111, 2408}, {-371, 2495}, {-525, 2518}, {666, 2544}, {193, 2546}, {-557, 2584}, {-106, 2604}, {233, 2613}, {446, 2624}, {-474, 2627}, {606, 2641}, {743, 2653}, {736, 2727}, {823, 2736}, {422, 2756}, {358, 2773}, {-67, 2779}, {823, 2792}, {628, 2813}, {967, 2812}, {572, 2837}, {783, 2850}, {584, 2852}, {455, 2855}, {1030, 2881}, {-287, 2911}, {-81, 2918}, {830, 2926}, {494, 2938}, {0, 2960}, {382, 2968}, {349, 2973}, {-116, 2984}, {370, 3008}, {726, 3019}, {361, 3046}, {890, 3052}, {153, 3065}, {203, 3083}, {284, 3178}, {433, 3195}, {590, 3212}, {856, 3224}, {654, 3237}, {567, 3289}, {520, 3294}, {520, 3295}, {488, 3395}, {495, 3409}, {633, 3464}}]; (* The following is how I generated the map example of Western Europe *) (* Needs["Miscellaneous`WorldPlot`"]; Needs["Miscellaneous`WorldData`"]; Unprotect[WorldData]; WorldData["Germany"] = {{{3194, 432}, {3212, 590}, {3295, 520}, {3289, 567}, {3237, 654}, {3224, 856}, {3052, 890}, {3019, 726}, {2926, 830}, {2850, 783}, {2852, 584}, {2852, 574}, {2855, 455}, {2938, 494}, {2968, 382}, {3008, 368}, {3045, 361}, {3194, 432}}}; Protect[WorldData]; elim[l_] := l //. {a___, b_, c___, b_, d___} :> {a, b, c, d} cc = {"Portugal", "Spain", "France", "Germany", "Italy", "Switzerland", "Austria", "Denmark", "Belgium", "Luxembourg", "Netherlands"}; df = {{3082, 202} -> {3083, 203}, {3045, 361} -> {3046, 361}, {2972, 349} -> {2973, 349}, {2812, 628} -> {2813, 628}, {2852, 574} -> {2852, 584}, {3194, 432} -> {3195, 433}, {3008, 368} -> {3008, 370}, {2812, 628} -> {2813, 628}, {2836, 572} -> {2837, 572}}; h[d_] := DeleteCases[d, Alternatives @@ Join[First[WorldData["Andorra"]], Reverse /@ {{854, 3236}, {597, 3423}, {576, 2824}, {574, 2852}, {567, 3290}}]] /. df f[c_] := Flatten[(Position[pts, #1] & ) /@ h[elim[First[WorldData[c] /. df]]]] fix[indices_] := Flatten[(Position[pts, #1] & ) /@ MakeCounterclockwise[pts[[indices]]]] *) USApts= {{-67.015406,44.863288},{-68.048834,47.263288},{-69.598977, 47.163288},{-71.149119,45.7},{-70.726353,43.196622},{-72.511365, 42.863288},{-73.356897,42.796621},{-73.450845,45.129955},{-75.047962, 44.996621},{-76.832974,43.696622},{-78.711934,43.729955},{-79.792336, 42.463288},{-79.62208,41.963288},{-75.38107,41.963288},{-74.845363, 41.463288},{-73.506097,42.063288},{-72.032904, 42.029956},{-71.273986, 42.129955},{-71.050775,41.463288},{-71.854335,41.296622},{-73.996551, 40.629955},{-74.877181,39.129955},{-75.581685,39.863288},{-75.713779, 38.496622},{-75.009275,38.496622},{-75.323187,38.029955},{-77.296369, 38.396622},{-77.741926,39.346622},{-78.166266,39.646622},{-79.48172, 39.279955},{-79.524154,39.763288},{-80.585004,39.763288},{-80.54257, 40.646622},{-80.54257,41.979955},{-83.310512,41.746622},{-82.425422, 43.046622},{-82.779458,43.879955},{-84.664009,45.846622},{-88.590163, 48.179955},{-92.066938,46.779955},{-87.596799,45.129955},{-87.880617, 42.496622},{-87.360283,41.629955},{-84.805918,41.729955},{-84.773633, 39.046622},{-82.425759,38.446622},{-82.027063,37.513288},{-79.812087, 38.396622},{-75.778082,36.529955},{-81.616774,36.596622},{-83.612545, 36.679955},{-89.395819,36.529955},{-89.167219,37.046622},{-87.941094, 37.913289},{-90.573969,42.546622},{-91.317488,43.513289},{-96.505458, 43.529955},{-96.645254,46.029955},{-97.161327,48.896622}, {-104.084813,48.996622},{-116.027331,48.996622}, {-116.992599,48.996622},{-124.280677, 48.896622},{-124.417844,42.029956}, {-124.001343,46.213289},{-116.916417,45.979956}, {-117.045501,42.029956},{-111.073895,41.996622}, {-111.003332,45.013289},{-104.005423,44.963289},{-104.005001,45.963289}, {-104.005001, 42.996622},{-96.569985,42.596622},{-95.778252,40.663289},{-95.422982, 40.013289},{-91.499361,40.379956},{-94.638312,37.029956},{-94.659519, 36.496623},{-90.481683,35.946622},{-90.227196,36.429956},{-89.718221, 35.946622},{-90.269611,34.979956},{-88.127674,34.913289},{-85.5828, 34.996623},{-84.246741,34.996623},{-83.163429,34.979956},{-81.089042, 35.113289},{-78.526565,33.796623},{-80.946682,32.046623},{-81.486297, 30.713289},{-80.143184,26.746623},{-80.535638,25.196623},{-82.440578, 27.446623},{-82.785134,29.029957},{-83.737135,29.896623},{-85.295666, 29.846623},{-87.508395,30.26329},{-87.566119,30.979956},{-85.007049, 31.046623},{-88.407889,30.36329},{-89.553975,30.21329},{-89.795256, 31.029956},{-91.624973,31.06329},{-91.182624,32.896623},{-94.206693, 33.06329},{-94.465347,33.629956},{-100.033265,34.56329},{-100.013237, 36.546623},{-103.056213,36.479957},{-103.03544,36.996623},{-102, 36.996623},{-102,39.996623},{-102,40.996623},{-104.087309, 41.01329},{-109.04118,41.029957},{-111.072763,41.046623},{-109.04118, 37.029957},{-114.009724,37.029957},{-120.136626,42.029956},{-122.277235, 36.56329},{-120.033161,38.979957},{-114.608669,35.01329},{-117.282481, 32.56329},{-114.636089,32.646623},{-111.092171,31.296623},{-109.021568, 31.36329},{-108.145543,31.31329},{-108.165749,31.76329},{-106.439793, 31.779957},{-103.04672,31.996624},{-103.242851,29.01329},{-101.470817, 29.76329},{-97.157352,25.979957},{-96.87106,28.36329},{-93.855452, 29.76329},{-89.80164,29.096624},{-114,42.029956}, {-70.879, 43.519}, {-71.8, 45.12}, {-76, 39.7}, {-90.1035, 46.0469}, {-85.0495, 46.6974}, {-85.4499, 46.0469}, {-84.9,45.2}, {-86.5, 41.62}, {-73.8499, 40.8147}, {-113.094, 45.0567}, {-115.807, 47.438}, {-70.1921, 43.9277}, {-70.0612, 41.5888}, {-70.879, 42.2594}}; StateNames = {"AL", "AR", "AZ", "CA", "CO", "CT", "DE", "FL", "GA", "IA", "ID", "IL", "IN", "KS", "KY", "LA", "MA", "MD", "ME", "MI", "MN", "MO", "MS", "MT", "NC", "ND", "NE", "NH", "NJ", "NM", "NV", "NY", "OH", "OK", "OR", "PA", "RI", "SC", "SD", "TN", "TX", "UT", "VA", "VT", "WA", "WI", "WV", "WY","LakeMichigan"}; AL={100,97,98,99,84,83}; AR={78,106,105,104,82,81,79,80}; AZ={124,125,126,117,118,122}; CA={120,123,124,122,121,119,64}; CO={117,110,111,112,113,114,115}; CT={17,16,146,20}; DE={24,25,22,23, 140}; FL={99,98,97,96,95,94,93,92,91,90}; GA={90,89,86,85,84,99}; IA={76, 55,56,57,73,74}; ID={69,147,148,61,62,66,67,137,68}; IL={43,42,55,76,53,54}; IN={43,54,45,44,145}; KS={77,75,112,111}; KS={77,75,112,111}; KY={47,46,45,54,53,52,51}; LA={135,136,101,102,103,104,105}; MA={5,6,7,16,17,18,19,150,151}; MD={140,29,31,30,28,27,49,26,25,24}; ME={1,2,3,4,138,149}; MI={145,44,35,36,37,38,142,141,41,143,144}; MN={40, 39, 59, 58, 57,56}; MO={76,74,75,77,78,80,79,81,52,53}; MS={101,100,83,82,104,103,102}; MT={60,61,148,147,69,70,71}; NC={88,49,50,85,86,87}; ND={59,60,71,58}; NE={73,72,114,113,112,75,74}; NH={5,138,4,139,6}; NJ={15,23,22,21}; NM={126,127,128,129,130,109,110,117}; NV={121,122,118, 137,67,119}; NY={8,9,10,11,12,13,14,15,21,146,16,7}; OH={35,44,45,46,33,34}; OK={111,110,109,108,107,106,78,77}; OR={119,67,66,65,64}; PA={14,13,12,34,33,32,31,29,140, 23,15}; RI={20,19,18,17}; SC={89,88,87,86}; SD={58, 71,70,72,73,57}; TN={50,51,52,81,82,83,84,85}; TX={131,132,133,134,135,105,106,107,108,109,130,129}; UT={117,115,116,68,137,118}; VA={50,49,27,28,48,47,51}; VT={8,7,6,139}; WA={65,66,62,63}; WI={55,42,41,141,40,56}; WV={46,47,48,28,30,31,32,33}; WY={70,69,68,116,115,114,72}; LakeMichigan = {145,144,143,41,42,43}; MapOfUSA = PlanarMap[ToExpression /@ StateNames, USApts]; USChallengeSolution = {1,1,3,4,3,1,2,2,3,1,3,2,3,1,1,2,3,1,1,2,2,3,3,2,1,1,2,2,1,1,1,2,4,2,2,3,2,2, 3,2,3,2,3,1,1,3,2,1,1}; MooreGraphPartial = PlanarGraph[ First[FromAdjacencyLists[{{2,3,6,340},{1,4,6,55,56,57,340},{1,5,6},{2,11,12,56,57,58,64},{3,6,7,8},{1, 2,3,5,8,9,55},{5,8,13,31},{5,6,7,9,13,14,25},{6,8,10,14,15,32,55},{9,11, 15,16,26,55,56},{4,10,12,16,17,33,56},{4,11,17,18,27,58,68},{7,8,19,25, 31},{8,9,20,25,32},{9,10,21,26,32},{10,11,22,26,33},{11,12,23,27,33},{12, 24,27,68,92},{13,25,31,34,37},{14,25,32,35,40},{15,26,32,35,38},{16,26,33, 36,41},{17,27,33,36,39},{18,27,42,92,95},{8,13,14,19,20,37,40},{10,15,16, 21,22,38,41},{12,17,18,23,24,39,42},{37,40,46,49},{38,41,47,50},{39,42,48, 51},{7,13,19,34},{9,14,15,20,21,35},{11,16,17,22,23,36},{19,31,37,43},{20, 21,32,38,40,44,59},{22,23,33,39,41,45,60},{19,25,28,34,40,43,46},{21,26, 29,35,41,44,47},{23,27,30,36,42,45,48},{20,25,28,35,37,49,59},{22,26,29, 36,38,50,60},{24,27,30,39,51,61,95},{34,37,46,52},{35,38,47,53,59},{36,39, 48,54,60},{28,37,43,52,211,220,226},{29,38,44,53,212,221,227},{30,39,45, 54,213,222,228},{28,40,53,59,211,223,233},{29,41,54,60,212,224,234},{30, 42,61,113,213,225,235},{43,46,226},{44,47,49,59,227,233},{45,48,50,60,228, 234},{2,6,9,10,56},{2,4,10,11,55},{2,4,62,64,340},{4,12,64,66,68},{35,40, 44,49,53},{36,41,45,50,54},{42,51,95,104,113},{57,63,64,67,340},{62,65,67, 116,117,118,340},{4,57,58,62,66,67},{63,72,73,117,118,119,125},{58,64,67, 68,69},{62,63,64,66,69,70,116},{12,18,58,66,69,74,92},{66,67,68,70,74,75, 86},{67,69,71,75,76,93,116},{70,72,76,77,87,116,117},{65,71,73,77,78,94, 117},{65,72,78,79,88,119,129},{68,69,80,86,92},{69,70,81,86,93},{70,71,82, 87,93},{71,72,83,87,94},{72,73,84,88,94},{73,85,88,129,153},{74,86,92,95, 98},{75,86,93,96,101},{76,87,93,96,99},{77,87,94,97,102},{78,88,94,97, 100},{79,88,103,153,156},{69,74,75,80,81,98,101},{71,76,77,82,83,99,102},{ 73,78,79,84,85,100,103},{98,101,107,110},{99,102,108,111},{100,103,109, 112},{18,24,68,74,80,95},{70,75,76,81,82,96},{72,77,78,83,84,97},{24,42, 61,80,92,98,104},{81,82,93,99,101,105,120},{83,84,94,100,102,106,121},{80, 86,89,95,101,104,107},{82,87,90,96,102,105,108},{84,88,91,97,103,106, 109},{81,86,89,96,98,110,120},{83,87,90,97,99,111,121},{85,88,91,100,112, 122,156},{61,95,98,107,113},{96,99,108,114,120},{97,100,109,115,121},{89, 98,104,113,263,272,278},{90,99,105,114,264,273,279},{91,100,106,115,265, 274,280},{89,101,114,120,263,275,285},{90,102,115,121,264,276,286},{91, 103,122,174,265,277,287},{51,61,104,107,235,278},{105,108,110,120,279, 285},{106,109,111,121,280,286},{63,67,70,71,117},{63,65,71,72,116},{63,65, 123,125,340},{65,73,125,127,129},{96,101,105,110,114},{97,102,106,111, 115},{103,112,156,165,174},{118,124,125,128,340},{123,126,128,177,178,179, 340},{65,118,119,123,127,128},{124,133,134,178,179,180},{119,125,128,129, 130},{123,124,125,127,130,131,177},{73,79,119,127,130,135,153},{127,128, 129,131,135,136,147},{128,130,132,136,137,154,177},{131,133,137,138,148, 177,178},{126,132,134,138,139,155,178},{126,133,139,140,149,180},{129,130, 141,147,153},{130,131,142,147,154},{131,132,143,148,154},{132,133,144,148, 155},{133,134,145,149,155},{134,146,149},{135,147,153,156,159},{136,147, 154,157,162},{137,148,154,157,160},{138,148,155,158,163},{139,149,155,158, 161},{140,149,164},{130,135,136,141,142,159,162},{132,137,138,143,144,160, 163},{134,139,140,145,146,161,164},{159,162,168,171},{160,163,169,172},{ 161,164,170,173},{79,85,129,135,141,156},{131,136,137,142,143,157},{133, 138,139,144,145,158},{85,103,122,141,153,159,165},{142,143,154,160,162, 166,181},{144,145,155,161,163,167,182},{141,147,150,156,162,165,168},{143, 148,151,157,163,166,169},{145,149,152,158,164,167,170},{142,147,150,157, 159,171,181},{144,148,151,158,160,172,182},{146,149,152,161,173,183},{122, 156,159,168,174},{157,160,169,175,181},{158,161,170,176,182},{150,159,165, 174,315,324,330},{151,160,166,175,316,325,331},{152,161,167,176,317,326, 332},{150,162,175,181,315,327,337},{151,163,176,182,316,328,338},{152,164, 183,317,329,339},{112,122,165,168,287,330},{166,169,171,181,331,337},{167, 170,172,182,332,338},{124,128,131,132,178},{124,126,132,133,177},{124,126, 340},{126,134},{157,162,166,171,175},{158,163,167,172,176},{164,173},{185, 186,189,341},{184,187,189,229,230,231,341},{184,188,189},{185,194,195,230, 231,232,238},{186,189,190,191},{184,185,186,188,191,192,229},{188,191,196, 214},{188,189,190,192,196,197,208},{189,191,193,197,198,215,229},{192,194, 198,199,209,229,230},{187,193,195,199,200,216,230},{187,194,200,201,210, 232,242},{190,191,202,208,214},{191,192,203,208,215},{192,193,204,209, 215},{193,194,205,209,216},{194,195,206,210,216},{195,207,210,242,266},{ 196,208,214,217,220},{197,208,215,218,223},{198,209,215,218,221},{199,209, 216,219,224},{200,210,216,219,222},{201,210,225,266,269},{191,196,197,202, 203,220,223},{193,198,199,204,205,221,224},{195,200,201,206,207,222,225},{ 46,49,220,223},{47,50,221,224},{48,51,222,225},{190,196,202,217},{192,197, 198,203,204,218},{194,199,200,205,206,219},{202,214,220,226},{203,204,215, 221,223,227,233},{205,206,216,222,224,228,234},{46,202,208,211,217,223, 226},{47,204,209,212,218,224,227},{48,206,210,213,219,225,228},{49,203, 208,211,218,220,233},{50,205,209,212,219,221,234},{51,207,210,213,222,235, 269},{46,52,217,220},{47,53,218,221,233},{48,54,219,222,234},{185,189,192, 193,230},{185,187,193,194,229},{185,187,236,238,341},{187,195,238,240, 242},{49,53,218,223,227},{50,54,219,224,228},{51,113,225,269,278},{231, 237,238,241,341},{236,239,241,281,282,283,341},{187,231,232,236,240,241},{ 237,246,247,282,283,284,290},{232,238,241,242,243},{236,237,238,240,243, 244,281},{195,201,232,240,243,248,266},{240,241,242,244,248,249,260},{241, 243,245,249,250,267,281},{244,246,250,251,261,281,282},{239,245,247,251, 252,268,282},{239,246,252,253,262,284,294},{242,243,254,260,266},{243,244, 255,260,267},{244,245,256,261,267},{245,246,257,261,268},{246,247,258,262, 268},{247,259,262,294,318},{248,260,266,269,272},{249,260,267,270,275},{ 250,261,267,270,273},{251,261,268,271,276},{252,262,268,271,274},{253,262, 277,318,321},{243,248,249,254,255,272,275},{245,250,251,256,257,273,276},{ 247,252,253,258,259,274,277},{107,110,272,275},{108,111,273,276},{109,112, 274,277},{201,207,242,248,254,269},{244,249,250,255,256,270},{246,251,252, 257,258,271},{207,225,235,254,266,272,278},{255,256,267,273,275,279,285},{ 257,258,268,274,276,280,286},{107,254,260,263,269,275,278},{108,256,261, 264,270,276,279},{109,258,262,265,271,277,280},{110,255,260,263,270,272, 285},{111,257,261,264,271,273,286},{112,259,262,265,274,287,321},{107,113, 235,269,272},{108,114,270,273,285},{109,115,271,274,286},{237,241,244,245, 282},{237,239,245,246,281},{237,239,288,290,341},{239,247,290,292,294},{ 110,114,270,275,279},{111,115,271,276,280},{112,174,277,321,330},{283,289, 290,293,341},{288,291,293,333,334,335,341},{239,283,284,288,292,293},{289, 298,299,334,335,336},{284,290,293,294,295},{288,289,290,292,295,296,333},{ 247,253,284,292,295,300,318},{292,293,294,296,300,301,312},{293,295,297, 301,302,319,333},{296,298,302,303,313,333,334},{291,297,299,303,304,320, 334},{291,298,304,305,314,336},{294,295,306,312,318},{295,296,307,312, 319},{296,297,308,313,319},{297,298,309,313,320},{298,299,310,314,320},{ 299,311,314},{300,312,318,321,324},{301,312,319,322,327},{302,313,319,322, 325},{303,313,320,323,328},{304,314,320,323,326},{305,314,329},{295,300, 301,306,307,324,327},{297,302,303,308,309,325,328},{299,304,305,310,311, 326,329},{168,171,324,327},{169,172,325,328},{170,173,326,329},{253,259, 294,300,306,321},{296,301,302,307,308,322},{298,303,304,309,310,323},{259, 277,287,306,318,324,330},{307,308,319,325,327,331,337},{309,310,320,326, 328,332,338},{168,306,312,315,321,327,330},{169,308,313,316,322,328,331},{ 170,310,314,317,323,329,332},{171,307,312,315,322,324,337},{172,309,313, 316,323,325,338},{173,311,314,317,326,339},{168,174,287,321,324},{169,175, 322,325,337},{170,176,323,326,338},{289,293,296,297,334},{289,291,297,298, 333},{289,291,341},{291,299},{171,175,322,327,331},{172,176,323,328,332},{ 173,329},{1,2,57,62,63,118,123,124,179},{184,185,231,236,237,283,288,289, 335}}]], {{1,1},{6,2},{0,3},{9,3},{1,4},{2.5,3},{0,6},{2,6},{4,6},{6,6},{8,6},{10,6},{ 1,7},{3,7},{5,7},{7,7},{9,7},{11,7},{1,9},{3,9},{5,9},{7,9},{9,9},{11,9},{ 2,8.5},{6,8.5},{10,8.5},{2,13},{6,13},{10,13},{0,8},{4,8},{8,8},{0,10.5},{ 4,10.5},{8,10.5},{1.5,11},{5.5,11},{9.5,11},{2.5,11},{6.5,11},{10.5,11},{ 0.5,12},{4.5,12},{8.5,12},{1.25,14},{5.25,14},{9.25,14},{3,14},{7,14},{11, 14},{0,14},{4,14},{8,14},{5,4},{7,4},{11,1},{11,4},{3.75,12},{7.75,12},{ 11.75,12},{13,1},{18,2},{12,3},{21,3},{13,4},{14.5,3},{12,6},{14,6},{16, 6},{18,6},{20,6},{22,6},{13,7},{15,7},{17,7},{19,7},{21,7},{23,7},{13,9},{ 15,9},{17,9},{19,9},{21,9},{23,9},{14,8.5},{18,8.5},{22,8.5},{14,13},{18, 13},{22,13},{12,8},{16,8},{20,8},{12,10.5},{16,10.5},{20,10.5},{13.5,11},{ 17.5,11},{21.5,11},{14.5,11},{18.5,11},{22.5,11},{12.5,12},{16.5,12},{ 20.5,12},{13.25,14},{17.25,14},{21.25,14},{15,14},{19,14},{23,14},{12, 14},{16,14},{20,14},{17,4},{19,4},{23,1},{23,4},{15.75,12},{19.75,12},{ 23.75,12},{25,1},{30,2},{24,3},{33,3},{25,4},{26.5,3},{24,6},{26,6},{28, 6},{30,6},{32,6},{34,6},{25,7},{27,7},{29,7},{31,7},{33,7},{35,7},{25,9},{ 27,9},{29,9},{31,9},{33,9},{35,9},{26,8.5},{30,8.5},{34,8.5},{26,13},{30, 13},{34,13},{24,8},{28,8},{32,8},{24,10.5},{28,10.5},{32,10.5},{25.5,11},{ 29.5,11},{33.5,11},{26.5,11},{30.5,11},{34.5,11},{24.5,12},{28.5,12},{ 32.5,12},{25.25,14},{29.25,14},{33.25,14},{27,14},{31,14},{35,14},{24, 14},{28,14},{32,14},{29,4},{31,4},{35,1},{35,4},{27.75,12},{31.75,12},{ 35.75,12},{1,27},{6,26},{0,25},{9,25},{1,24},{2.5,25},{0,22},{2,22},{4, 22},{6,22},{8,22},{10,22},{1,21},{3,21},{5,21},{7,21},{9,21},{11,21},{1, 19},{3,19},{5,19},{7,19},{9,19},{11,19},{2,19.5},{6,19.5},{10,19.5},{2, 15},{6,15},{10,15},{0,20},{4,20},{8,20},{0,17.5},{4,17.5},{8,17.5},{1.5, 17},{5.5,17},{9.5,17},{2.5,17},{6.5,17},{10.5,17},{0.5,16},{4.5,16},{8.5, 16},{5,24},{7,24},{11,27},{11,24},{3.75,16},{7.75,16},{11.75,16},{13,27},{ 18,26},{12,25},{21,25},{13,24},{14.5,25},{12,22},{14,22},{16,22},{18,22},{ 20,22},{22,22},{13,21},{15,21},{17,21},{19,21},{21,21},{23,21},{13,19},{ 15,19},{17,19},{19,19},{21,19},{23,19},{14,19.5},{18,19.5},{22,19.5},{14, 15},{18,15},{22,15},{12,20},{16,20},{20,20},{12,17.5},{16,17.5},{20, 17.5},{13.5,17},{17.5,17},{21.5,17},{14.5,17},{18.5,17},{22.5,17},{12.5, 16},{16.5,16},{20.5,16},{17,24},{19,24},{23,27},{23,24},{15.75,16},{19.75, 16},{23.75,16},{25,27},{30,26},{24,25},{33,25},{25,24},{26.5,25},{24,22},{ 26,22},{28,22},{30,22},{32,22},{34,22},{25,21},{27,21},{29,21},{31,21},{ 33,21},{35,21},{25,19},{27,19},{29,19},{31,19},{33,19},{35,19},{26,19.5},{ 30,19.5},{34,19.5},{26,15},{30,15},{34,15},{24,20},{28,20},{32,20},{24, 17.5},{28,17.5},{32,17.5},{25.5,17},{29.5,17},{33.5,17},{26.5,17},{30.5, 17},{34.5,17},{24.5,16},{28.5,16},{32.5,16},{29,24},{31,24},{35,27},{35, 24},{27.75,16},{31.75,16},{35.75,16},{18,-2},{18,30}}]; MooreGraphPartialFourColoring = {2,3,3,4,2,1,3,4,3,2,3,2,2,2,4,4,4,4,4,3,3,2,2,1,1,1,3,1,4,3,1,1,1,2,4,4,3, 2,1,2,3,2,1,3,2,4,1,4,3,2,1,2,2,3,4,1,2,3,1,1,4,3,2,1,4,2,4,1,3,2,4,2,3,4, 1,1,1,1,1,1,4,4,3,3,4,2,2,2,3,1,2,2,3,4,3,2,1,4,3,4,1,4,3,1,1,2,2,4,1,4,2, 4,3,2,4,1,3,1,2,3,3,2,2,1,3,4,1,4,4,3,1,4,1,2,2,4,2,2,4,4,4,2,4,4,2,3,1,1, 1,1,4,3,3,3,3,1,1,1,3,3,4,4,2,2,4,2,3,2,1,1,2,1,1,3,4,2,2,3,2,1,3,4,3,1,3, 2,4,1,4,4,2,3,4,3,1,3,4,1,2,4,4,4,3,4,4,2,2,1,3,3,1,4,2,1,2,1,2,1,3,3,2,1, 2,1,4,1,3,2,2,1,2,2,4,4,2,1,3,3,1,4,2,3,1,3,1,3,2,4,4,4,2,1,4,2,1,1,1,2,2, 3,3,3,1,3,2,1,2,4,3,4,3,4,2,4,2,4,1,1,1,2,4,2,2,4,3,1,2,1,3,3,2,1,4,3,2,3, 2,1,4,4,4,4,3,3,3,2,2,3,2,2,2,1,1,1,1,4,2,1,1,4,3,4,1,4,2,4,3,3,3,1,3,3,1, 4,1,1,1,4,2,4,4}; (*MooreGraphPartial = Module[{pts, edges, ee}, pts = Join[{{1,1},{6,2},{0,3},{9,3}, {1,4},{2.5,3}}, Table[{x,6},{x,0,10,2}], Table[{x,7}, {x,1,11,2}], Table[{x,9}, {x,1,11,2}], Table[{x,8.5}, {x,2,10,4}], Table[{x,13}, {x,2,10,4}], Table[{x,8}, {x,0,8,4}], Table[{x,10.5}, {x,0,8,4}], Table[{x,11}, {x,1.5,9.5,4}], Table[{x,11}, {x,2.5,10.5,4}], Table[{x,12}, {x,0.5,8.5,4}], Table[{x,14}, {x,1.25,9.25,4}], Table[{x,14}, {x,3,11,4}], Table[{x,14}, {x,0,8,4}], {{5,4}, {7,4},{11,1}, {11,4}}, Table[{x,12}, {x, 3.75, 11.75,4}]]; (p1=Join[pts, pts /. {x_,y_}:> {x+12,y}, pts /. {x_,y_} :> {x+24,y} ]); (p2=(DeleteCases[p1, _?(#[[2]]==14&)] /. {x_, y_}:> {x,28-y} )); (p3={{18,-2},{18,30}}); allPts = Join[p1,p2,p3]; equator = {52, 46, 28, 49, 53, 47, 50, 54, 48}; equator = Join[equator, equator + 61, equator + 122]; edges=Join[ ee = {{1,3},{1,6}, {1,2}, {2,6},{2,55},{2,56},{2,4},{2,57}, {3,5},{3,6}, {4,56},{4,57},{4,11},{4,12},{4,58},{5,6},{5,7},{5,8}, {6,8},{6,9},{6,55}, {7,8},{7,13},{7,31}, {8,9}, {8,13}, {8,25}, {8,14}, {9,14},{9,32},{9,15},{9,10}, {9,55}, {10, 55}, {10,56}, {10,11}, {10,16}, {10,26}, {10,15}, {11,56}, {11,16}, {11,33}, {11,17}, {11,12}, {12,58}, {12,18}, {12,27}, {12,17}, {13,31}, {13,19}, {13,25}, {14,25}, {14,20}, {14,32}, {15,32}, {15,21}, {15,26}, {16,26}, {16,22}, {16,33}, {17,33}, {17,23}, {17,27}, {18,27}, {18,24}, {19,31}, {19,34}, {19,25},{19,37}, {20,25}, {20,40}, {20,35},{20,32},{21,32},{21,35},{21,38}, {21,26}, {22,26}, {22,33}, {22,36},{22,41}, {23,33}, {23,36}, {23,27}, {23,39}, {24,42}, {24,27}, {25, 37}, {25,40}, {26,38}, {26,41}, {27,39}, {27,42}, {28,37}, {28,40}, {28,49}, {28,46}, {29, 38}, {29,41}, {29, 47}, {29,50}, {30,39}, {30, 42}, {30, 48}, {30, 51}, {31,34}, {32,35}, {33,36}, {34,37}, {34,43}, {35,40}, {35,38}, {35,59}, {35,44}, {36, 41}, {36,60}, {36,45}, {36,39}, {37,40}, {37,43}, {37,46}, {38,41}, {38,44}, {38,47}, {39,45}, {39,42}, {39,48}, {40, 59}, {40, 49}, {41,50}, {41,60}, {42, 61}, {42, 51}, {43,46}, {43,52}, {44,59}, {44,53}, {44,47}, {45,48}, {45,54}, {45, 60}, {46,52}, {47,53}, {48,54}, {49,59}, {49,53}, {50,60}, {50,54}, {51,61}, {53,59}, {54,60}, {55,56}}, ee +61, ee + 122, ff={{57,62}, {57,64}, {4,64}, {58,64}, {58,66}, {58,68}, {12,68}, {18,68}, {18,92}, {24,92}, {24,95},{42,95},{61,95},{61,104},{61,113}, {51,113}}, ff+61]; edges = Join[edges, edges /. {x_, y_} :> Flatten[{Position[allPts, {0, 28} + {1,-1}*allPts[[x]]], Position[allPts, {0, 28} + {1,-1} allPts[[y]]]}]]; edges = Join[edges, sp = {{340, 1}, {340, 2}, {340, 57}}, sp /. {340, y_} :> {340, y+61}, sp /. {340, y_} :> {340, y+122}, {{341,184}, {341, 185}, {341,231}, {341,236}, {341, 237}, {341, 283}, {341, 288}, {341, 289}, {341, 335}}]; PlanarGraph @@ AddEdges[Graph[EmptyGraph[341][[1]], allPts], edges]] *) MooreGraph = Module[{},th = -114. Degree; rot = {{Cos[th], -Sin[th]},{Sin[th], Cos[th]}}; rot1 = {{Cos[th], Sin[th]},{-Sin[th], Cos[th]}}; pts = MooreGraphPartial[[2]]; pts[[340]] = {18, -26}; Scan[(pts=ReplacePart[pts, rot . ((pts[[#]] /. {x_,y_} :> {0,y} ) - {0, 7} - pts[[184]]) + pts[[184]],#]) & , {1,3,5,7,31,34,43,52,226,217,214,190, 188, 186, 184}]; Scan[(pts=ReplacePart[pts, rot1 . ((pts[[#]] /. {x_,y_} :> {35,y} ) - {0, 7} - pts[[335]]) + pts[[335]],#]) & , {179, 126,180, 134, 140,146,164,183, 173, 339,329,311,305,299,336,291,335}]; pts[[341]] = {18, 29.5}; Scan[(pts=ReplacePart[pts, pts[[#]] /. {x_,y_} :> {1,y}, #]) & , {2,6,8,13, 37, 46,191, 189, 220}]; Scan[(pts=ReplacePart[pts, pts[[#]] /. {x_,y_} :> {34,y}, #])& , {124,133,139,149,152,161,178,289,298,304,314,317,326,334}]; mooretemp = PlanarGraph @@ AddEdges[Graph @@ MooreGraphPartial, {{1,179}, {3,179},{3,126},{3,180}, {5,180}, {7,134},{7,140},{7,180}, {31,140},{31,146}, {34,183},{34,146},{34,164}, {43,183}, {52,183},{52,173},{52,339}, {226,339}, {217,339},{217,329},{217,311}, {214,311},{214,305}, {190,305},{190,299}, {190,336}, {188,336}, {186,336},{186,291},{186,335}, {184,335} }]; pts[[185]] = pts[[185]] + {0,2}; pts[[289]] = pts[[289]] + {0,-1}; pts[[134]] = pts[[134]] + {1.2,0}; pts[[126]] = pts[[126]] + {0.7,0.2}; pts[[180]] = pts[[180]] + {-2,0}; pts[[173]] = pts[[173]] + {.2,-0.6}; pts[[329]] = pts[[329]] + {.2,-0.6}; pts[[183]] = pts[[183]] + {-2,0}; pts[[339]] = pts[[339]] + {-2,0}; pts[[291]] = pts[[291]] + {-3,-0.5}; pts[[336]] = pts[[336]] + {-6,0}; pts[[299]] = pts[[299]] + {-2,0}; pts[[2]] = pts[[2]] + {-.5, -1}; pts[[184]] = pts[[184]] + {1, 0.2}; pts[[185]] = pts[[185]] + {2, -1}; pts[[236]] = pts[[236]] + {2, -0.2}; pts[[237]] = pts[[237]] + {0, -0.2}; pts[[231]] = pts[[231]] + {1.5, -0.2}; pts[[283]] = pts[[283]] + {-2, -0.2}; pts[[288]] = pts[[288]] + {-1.5, -0.2}; pts[[341]] = pts[[341]] + {0, -1}; pts[[184]] = pts[[184]] + {6, -0.8}; pts[[335]] = pts[[335]] + {-11,-0.5}; pts[[186]] = pts[[186]] + {3,-0.3}; pts[[185]] = pts[[185]] + {0,1.5}; pts[[289]] = pts[[289]] + {0,1.5}; pts[[124]] = pts[[124]] + {1.5,-1}; PlanarGraph[mooretemp[[1]], pts]]; KempeOrder[g_PlanarGraph | g_Graph, pre_:{}] := Module[ {degs = DegreeSequenceOrdered[g], vert}, Scan[(degs = ReplacePart[degs, Infinity, #])&, pre]; Join[ Table[ vert = First[Select[Range[V[g]], degs[[#]] < 6 &, 1]]; degs[[vert]] = Infinity; degs -= g[[1, vert]]; vert, {V[g]-Length[pre]}],pre]] (* The couple of routines that follow are optimized to save memory (and time). Thus the graph is not passed as an argument to KempeChain; rather only adjacencies are used in "gadj". And the Kempe chain itself is found directly, by some customized Neighbors routines, as opposed to the earlier way of using a large matrix. Planar graphs are sparse, so it makes sense to use adjacency lists! *) Options[FourColoringNonRecursive] = {PrintTraceData->False, MaxTries -> 100,KittellTrace->False, AlgorithmTrace->False, Precolored->{}, Method -> Kempe, TraceIncrement -> 10}; FourColoringNonRecursive[g_Graph | g_PlanarGraph, order_List, opts___] := Module[{cols, td, mx}, kem = 1; fc = {}; {traceQ, td, pre, inc, met, mx, kittrace} = {AlgorithmTrace,PrintTraceData, Precolored, TraceIncrement, Method, MaxTries, KittellTrace} /. {opts} /.Options[FourColoringNonRecursive]; cols = Last /@ pre; len = Length[pre]; If[traceQ, orderTemp = order]; Do[If[td && Mod[j, inc]==0, Print[{j, order[[-j]]}]]; If[traceQ, specialvert = order[[-j]]; gtemp = InduceSubgraph[g, Take[order, {-j+1,-1}]]]; nbrs = Neighbors[ InduceSubgraph[g, Take[order,{-j,-1}]], 1]-1; If[Length[Union[cols[[nbrs]]]] < 4, cols = Flatten[{First[Complement[Range[4], cols[[nbrs]]]], cols}]; If[traceQ, Scan[(tracecols = ReplacePart[tracecols, cols[[j+1-#]], {order[[-#]]}])&, Range[j]]; ShowColoredGraph[main, tracecols, Epilog -> labs, Prolog -> {AbsolutePointSize[32], Point[main[[2, order[[-j]]]]]}, PlotRange -> pr]], (* else go into Kempe Chain mode *) gadj = ToAdjacencyLists[ InduceSubgraph[g, Take[order, {-j+1,-1}]]]; pts = N[InduceSubgraph[g, Take[order, {-j,-1}]][[ 2, Prepend[nbrs+1,1]]]]; nbrs = nbrs[[Flatten[(Position[Rest[pts], #]& /@ (MakePointsCounterclockwise[Rest[pts], First[pts]]))]]]; If[Length[nbrs] == 4, If[td, Print[StringForm[ "Kempe Chain (degree 4 case) number ``", kem++]]]; fc1 = KempeChain[nbrs[[{1,3}]], cols, AlgorithmTrace->traceQ]; fc = If[fc1 =!= False, fc1, fc2 = KempeChain[nbrs[[{2,4}]], cols, AlgorithmTrace->traceQ]; If[fc2 =!= False, fc2, Message[FourColoring::subdv]; Return[$Failed]]], (* so now vertex degree must be 5 and 4 colors in ring with 1 repeat *) If[met === KittellOnly, icount = 0; Do[icount++; w = nbrs[[Random[Integer, {1,5}]]]; c1 = DeleteCases[Range[4], cols[[w]]][[ Random[Integer, {1,3}]]]; If[Length[Union[cols[[nbrs]]]] < 4, Break[]]; v = Select[nbrs, cols[[#]] == c1 &]; cols = KempeSwitch[{w,v}, cols, AlgorithmTrace -> traceQ]; If[traceQ, Scan[(tracecols = ReplacePart[tracecols, cols[[j-#]], {order[[-#]]}])&, Range[j-1]]], {i, mx}]; If[kittrace, Print[StringForm["`` random Kempe switches were needed to resolve the impasse.",icount]]]; fc = If[icount == mx, $Failed, cols], If[td, Print[StringForm[ "Kempe Chain (degree 5 case) number ``", kem++]]]; nbrsColors = cols[[nbrs]];(* find colors in ring *) dupColor = First[Select[nbrsColors, Count[nbrsColors, #] == 2 &,1]]; samecolorNbrs = Select[nbrs,cols[[#]]==dupColor &,2]; samecolorIndices = Sort[Flatten[ Position[nbrs, #] & /@ samecolorNbrs]]; If[MemberQ[{1,4}, Abs[Subtract @@ samecolorIndices]], (* case adjacent *) v1 = samecolorIndices/.{{1,5}->1, {m_,n_} :> n}; v3 = First[DeleteCases[samecolorIndices, v1]]; v2 = v1 + 2; fc1 = KempeChain[{nbrs[[ mod5Fix[v2]]],nbrs[[mod5Fix /@ {v1,v3}]]}, cols,AlgorithmTrace->traceQ]; fc = If[fc1 =!= False, fc1, KempeChain[ nbrs[[mod5Fix /@ {v1+1,v2+1}]], cols, AlgorithmTrace->traceQ]], (* split case *) v1 = (samecolorIndices /. {{1,4} -> 1, {2,5}->2, {m_, n_} :> n}) - 1; v2 = v1 + 2; fc1 = KempeChain[nbrs[[mod5Fix /@ {v1,v2}]], cols, AlgorithmTrace->traceQ]; fc = If[fc1 =!= False, fc1, fc1 = KempeChain[ nbrs[[mod5Fix/@{v1,v2+1}]],cols, AlgorithmTrace->traceQ]; If[fc1 =!= False, fc1, fc1 = KempeChain[ nbrs[[mod5Fix /@{v1+1,v2+1}]], cols, AlgorithmTrace->traceQ]; If[fc1 === False, Message[FourColoring::subdv];Return[$Failed], If[traceQ,Scan[ (tracecols = ReplacePart[tracecols, fc1[[j-#]], {order[[-#]]}])&, Range[j-1]]]; fc2 = KempeChain[nbrs[[mod5Fix /@ {v1-1, v2}]], fc1, AlgorithmTrace->traceQ]; If[fc2 =!= False, fc2, If[met =!= Kittell, Message[FourColoring::failed];Return[$Failed], (* otherwise try Kittell's method *) If[kittrace, Print[FourColoring::kittel]]; icount = 0; cols = fc1; Do[icount++; w = nbrs[[Random[Integer, {1,5}]]]; c1 = DeleteCases[Range[4], cols[[w]]][[ Random[Integer, {1,3}]]]; If[Length[Union[cols[[nbrs]]]] < 4, Break[]]; v = Select[nbrs, cols[[#]] == c1 &]; cols = KempeSwitch[{w,v}, cols, AlgorithmTrace -> traceQ]; If[traceQ, Scan[(tracecols = ReplacePart[tracecols, cols[[j-#]], {order[[-#]]}])&, Range[j-1]]], {i, mx}]; If[kittrace, Print[StringForm["`` random Kempe switches were needed to resolve the impasse.",icount]]]; If[icount == mx, $Failed, cols]] ]] ]] ] (* End If for 2 cases *) ]]; If[fc =!= $Failed, cols = Flatten[ {First[Complement[Range[4], fc[[nbrs]]]], fc}]; If[traceQ, Scan[(tracecols = ReplacePart[tracecols, cols[[j+1-#]], {order[[-#]]}])&, Range[j]]; ShowColoredGraph[main, tracecols, Epilog -> labs, Prolog -> {AbsolutePointSize[32], Point[main[[2, order[[-j]]]]]}, PlotRange -> pr]]]], {j, len+1, V[g]}]; If[fc === $Failed, fc, cols[[InversePermutation[order]]]]] (* following assumes gadj is a list of adjacencies only *) Neighbors[adj_List,v_Integer, col_, goodcol_] := Select[Flatten[{adj[[v]],v}], MemberQ[goodcol,col[[#]]]&] (* The preceding routine is a special case for use in KempeChain, which is optimized for memory saving. *) Options[KempeChain] = {AlgorithmTrace->False}; KempeChain[ {v1_, vv2_}, coloring_List, opts___] := ({algtraceQ} = {AlgorithmTrace} /. {opts} /. Options[KempeChain]; answer = coloring; chold = {}; chain = {v1}; While[(fail = (Intersection[Flatten[{vv2}], chain] == {})) && chain != chold, {chold,chain} = {chain, Union[chain, Union @@ (Neighbors[gadj, #, coloring, coloring[[Flatten[{v1,vv2}]]]]& /@ chain)]}]; If[algtraceQ, verts2 = Flatten[{vv2}]; ss = Select[EdgeSet[main], Complement[#, chain /. n_Integer :> posn[main, gtemp, n]] == {} &]; spokes = Select[EdgeSet[main], !FreeQ[#, specialvert] &]; g2 = Graph[Array[0&, {V[main], V[main]}], main[[2]]]; mainlines = (Line[main[[2, #]]] &) /@ EdgeSet[DeleteEdges[main, Join[ss, spokes]]]; ShowColoredGraph[g2, tracecols, Prolog -> {{mainlines, AbsoluteThickness[5], Line[main[[2, #]]]& /@ spokes, AbsoluteThickness[7], RGBColor[1, 1, 1], Line[main[[2, #]]]& /@ ss}, {AbsolutePointSize[32], GrayLevel[0], Point[main[[2, specialvert]]], Point[main[[2, posn[main, gtemp, v1]]]], RGBColor[0,0,1], Point[main[[2, posn[main, gtemp, #]]]] & /@ verts2, RGBColor[1,1,1], Point[main[[2, posn[main, gtemp, #]]]]& /@ DeleteCases[chain, Alternatives @@ Flatten[{v1, verts2}]]}}, Epilog -> labs, PlotRange -> pr]]; fail /. True :> (Scan[(answer = ReplacePart[answer, Complement[coloring[[Flatten[{v1, vv2}]]], {answer[[#]]}][[1]], #])&, chain]; If[algtraceQ, coltemp = tracecols; Scan[(coltemp = ReplacePart[coltemp, answer[[j-#]], {orderTemp[[-#]]}])&, Range[j-1]]; ShowColoredGraph[g2, coltemp, Prolog -> {{mainlines, AbsoluteThickness[5], Line[main[[2, #]]]& /@ spokes, AbsoluteThickness[7], RGBColor[1,1,1], (Line[main[[2, #]]] & ) /@ ss}, {AbsolutePointSize[32], GrayLevel[0], Point[main[[2, specialvert]]], Point[main[[2, posn[main, gtemp, v1]]]], RGBColor[0,0,1], Point[main[[2, posn[main, gtemp, #]]]] & /@ verts2, RGBColor[1,1,1], Point[main[[2, posn[main, gtemp, #]]]]& /@ DeleteCases[chain, Alternatives @@ Flatten[{v1, verts2}]]}}, Epilog -> labs, PlotRange -> pr]]; answer)) ErreraGraphOnSphere := ( d = N[Degree]; ht = 15; del = 1.005; arctic = 45 d; borderColor = RGBColor[1,0,0]; rule = (Line[x_] :> {borderColor, th, Line[x]}); th = AbsoluteThickness[3]; SetOptions[ParametricPlot3D, PlotPoints->20]; Show[Graphics3D[ {Sphere[1, 25, 25]}, Boxed->False, DisplayFunction->Identity], phi = arctic; ParametricPlot3D[del{ Cos[phi] Sin[theta], Cos[phi] Cos[theta], Sin[phi]},{theta, 0, 2 Pi} , DisplayFunction->Identity] /. rule, phi = -arctic; ParametricPlot3D[del{ Cos[phi] Sin[theta], Cos[phi] Cos[theta], Sin[phi]},{theta, 0, 2 Pi} , DisplayFunction->Identity] /. rule, Table[ ParametricPlot3D[del{ Cos[phi] Sin[theta], Cos[phi] Cos[theta], Sin[phi]},{phi, -8 d, 8 d} , DisplayFunction->Identity] /. rule,{theta, 0, 288 d, 72 d}], Table[ParametricPlot3D[del{ Cos[phi] Sin[theta- (phi-8 d)/(ht d) 36 d], Cos[phi] Cos[theta- (phi-8 d)/(ht d) 36 d], Sin[phi]},{phi, 8 d, (8+ht) d} , DisplayFunction->Identity] /. rule, {theta, 0, 288 d, 72 d}], Table[ ParametricPlot3D[del{ Cos[phi] Sin[theta+ (phi+8 d)/(ht d) 36 d], Cos[phi] Cos[theta+ (phi+8 d)/(ht d) 36 d], Sin[phi]},{phi, -8 d, (-8-ht) d} , DisplayFunction->Identity] /. rule, {theta, 0, 288 d, 72 d}], Table[ParametricPlot3D[del{ Cos[phi] Sin[theta+ (phi-8 d)/(ht d) 36 d], Cos[phi] Cos[theta+ (phi-8 d)/(ht d) 36 d], Sin[phi]},{phi, 8 d, (8+ht) d} , DisplayFunction->Identity] /. rule,{theta, 0, 288 d, 72 d}], Table[ParametricPlot3D[del{ Cos[phi] Sin[theta- (phi+8 d)/(ht d) 36 d], Cos[phi] Cos[theta- (phi+8 d)/(ht d) 36 d], Sin[phi]},{phi, -8 d, (-8-ht) d} , DisplayFunction->Identity] /. rule, {theta, 0, 288 d, 72 d}], Table[ParametricPlot3D[del{ Cos[phi] Sin[theta], Cos[phi] Cos[theta], Sin[phi]},{phi, (8+ht) d , arctic} , DisplayFunction->Identity] /. rule, {theta, 36d, (288+36) d, 72 d}], Table[ParametricPlot3D[del{ Cos[phi] Sin[theta], Cos[phi] Cos[theta], Sin[phi]},{phi, (-8-ht) d, -arctic} , DisplayFunction->Identity] /. rule, {theta, 36d, (288+36) d, 72 d}], DisplayFunction->$DisplayFunction, LightSources -> {{{1.,0.,1.},GrayLevel[0.35]}, {{1.,1.,1.},GrayLevel[0.35]}, {{0.,1.,1.},GrayLevel[0.35]}}, ViewPoint->{1.4, -2.6, 0.2}];) (* KempeSwitch that follows differs from KempeChain in that it actually performs the color switches, whether or not a target is reached *) Options[KempeSwitch] = {AlgorithmTrace -> False}; KempeSwitch[{v1_, vv2_}, coloring_List, opts___] := Module[ {algtraceQ}, algtraceQ = AlgorithmTrace /. {opts} /. Options[KempeSwitch]; answer = coloring; chain = FixedPoint[(Union[#, Union @@ (Function[vv, Neighbors[gadj, vv, coloring, coloring[[Flatten[{v1, vv2}]]]]] /@ #)]) &, {v1}]; If[algtraceQ, verts2 = Flatten[{vv2}]; ss = Select[EdgeSet[main], Complement[#, chain /. n_Integer :> posn[main, gtemp, n]] == {} &]; spokes = Select[EdgeSet[main], !FreeQ[#, specialvert] &]; g2 = Graph[Array[0&, {V[main], V[main]}], main[[2]]]; mainlines = (Line[main[[2, #]]] &) /@ EdgeSet[DeleteEdges[main, Join[ss, spokes]]]; ShowColoredGraph[g2, tracecols, Prolog -> {{mainlines, AbsoluteThickness[5], Line[main[[2, #]]]& /@ spokes, AbsoluteThickness[7], RGBColor[1, 1, 1], Line[main[[2, #]]]& /@ ss}, {AbsolutePointSize[32], GrayLevel[0], Point[main[[2, specialvert]]], Point[main[[2, posn[main, gtemp, v1]]]], RGBColor[0,0,1], Point[main[[2, posn[main, gtemp, #]]]] & /@ verts2, RGBColor[1,1,1], Point[main[[2, posn[main, gtemp, #]]]]& /@ DeleteCases[chain, Alternatives @@ Flatten[{v1, verts2}]]}}, Epilog -> labs, PlotRange -> pr]]; Scan[(answer = ReplacePart[answer, Complement[coloring[[Flatten[{v1, vv2}]]], {answer[[#]]}][[1]], #]) &, chain]; If[algtraceQ, coltemp = tracecols; Scan[(coltemp = ReplacePart[coltemp, answer[[j-#]], {orderTemp[[-#]]}])&, Range[j-1]]; ShowColoredGraph[g2, coltemp, Prolog -> {{mainlines, AbsoluteThickness[5], Line[main[[2, #]]]& /@ spokes, AbsoluteThickness[7], RGBColor[1,1,1], (Line[main[[2, #]]] & ) /@ ss}, {AbsolutePointSize[32], GrayLevel[0], Point[main[[2, specialvert]]], Point[main[[2, posn[main, gtemp, v1]]]], RGBColor[0,0,1], Point[main[[2, posn[main, gtemp, #]]]] & /@ verts2, RGBColor[1,1,1], Point[main[[2, posn[main, gtemp, #]]]]& /@ DeleteCases[chain, Alternatives @@ Flatten[{v1, verts2}]]}}, Epilog -> labs, PlotRange -> pr]]; answer] KittellGraph = PlanarGraph[{ {0,0,0,0,0,1,0,0,0,0,1,0,1,0,0,0,1,0,0,0,0,0,1}, {0,0,1,1,0,0,0,0,0,0,1,0,0,0,0,0,0,1,0,1,0,0,0}, {0,1,0,0,0,0,0,0,0,0,0,1,0,0,1,1,0,1,0,1,0,0,0}, {0,1,0,0,0,0,0,1,0,0,1,0,0,1,0,0,0,0,0,1,0,0,0}, {0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,0,1,0,0,0,1,0,1}, {1,0,0,0,0,0,0,0,0,0,1,1,1,1,0,0,0,0,1,0,0,1,0}, {0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,1,0,0}, {0,0,0,1,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,1,0,1,0}, {0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,1,0,0,1,0,1,0,0}, {0,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,0,0,1,0,1,0,1}, {1,1,0,1,0,1,0,0,0,0,0,0,0,1,0,0,1,1,0,0,0,0,0}, {0,0,1,0,0,1,0,0,1,0,0,0,0,0,1,1,0,0,1,0,0,1,0}, {1,0,0,0,0,1,0,0,0,1,0,0,0,0,0,0,0,0,1,0,0,0,1}, {0,0,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,1,0}, {0,0,1,0,0,0,0,1,0,0,0,1,0,0,0,0,0,0,0,1,0,1,0}, {0,0,1,0,0,0,1,0,1,0,0,1,0,0,0,0,0,1,0,0,1,0,0}, {1,0,0,0,1,0,1,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0,1}, {0,1,1,0,0,0,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0}, {0,0,0,0,0,1,0,0,1,1,0,1,1,0,0,0,0,0,0,0,0,0,0}, {0,1,1,1,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0}, {0,0,0,0,1,0,1,0,1,1,0,0,0,0,0,1,0,0,0,0,0,0,0}, {0,0,0,0,0,1,0,1,0,0,0,1,0,1,1,0,0,0,0,0,0,0,0}, {1,0,0,0,1,0,0,0,0,1,0,0,1,0,0,0,1,0,0,0,0,0,0}}, {{10.5,3},{22,0},{10,18},{18,2.5},{5,3}, {11.7,5.6},{1.8,1.5},{14,7},{7.9,9},{7.5,6}, {12.8,1},{9,13},{9.5,6},{15,4},{11,13},{6.5,10}, {7,1.8},{-1,0},{9.5,9},{13.5,10.5},{5.7,6.5}, {12,8.5},{8,3.5}}]; MapAprilFools = PlanarMap[{{119,120,121,254,235,237,239,253},{233,236,234,231,227,230},{234,237,235,232, 228,231},{161,170,162,153,152},{162,171,163,154,153},{163,172,164,155, 154},{164,173,165,156,155},{165,174,166,157,156},{166,175,167,158,157},{ 167,176,168,159,158},{168,177,169,160,159},{240,239,237,234,236,238},{144, 101,102,244,178,170,161,243},{27,35,42,95,105,104,103,94},{27,94,103,102, 101,93,10,19},{95,42,49,55,96,107,106,105},{96,55,61,66,97,109,108,107},{ 97,66,71,75,98,111,110,109},{98,75,79,82,99,113,112,111},{99,82,85,87,100, 115,114,113},{20,12,21,29,36,28},{21,13,22,30,37,29},{22,14,23,31,38,30},{ 23,15,24,32,39,31},{24,16,25,33,40,32},{25,17,26,34,41,33},{241,240,238, 250,114,115,116,251},{152,242,147,149,91,5,4,3,2,1,143,144,243,161},{92, 151,150,242,152,153,154,155,156,157,158,159,160,261,134,133,132,135,18, 9},{145,90,146,117,252,241,251},{117,118,119,253,239,240,241,252},{133, 134,261,160,169,260},{85,83,86,88,89,87},{90,89,88,142,118,117,146},{143, 1,10,93,101,144},{89,90,145,116,115,100,87},{149,148,92,9,8,7,6,91},{1,2, 11,19,10},{2,3,12,20,11},{3,4,13,21,12},{4,5,14,22,13},{5,91,6,15,23,14},{ 6,7,16,24,15},{7,8,17,25,16},{8,9,18,26,17},{18,135,132,131,130,136,34, 26},{19,11,20,28,35,27},{35,28,36,43,49,42},{36,29,37,44,50,43},{37,30,38, 45,51,44},{38,31,39,46,52,45},{39,32,40,47,53,46},{40,33,41,48,54,47},{41, 34,136,130,129,128,137,48},{79,76,80,83,85,82},{80,77,81,84,86,83},{86,84, 141,120,119,118,142,88},{71,67,72,76,79,75},{72,68,73,77,80,76},{73,69,74, 78,81,77},{74,70,139,124,123,122,140,78},{78,140,122,121,120,141,84,81},{ 61,56,62,67,71,66},{62,57,63,68,72,67},{63,58,64,69,73,68},{64,59,65,70, 74,69},{65,60,138,126,125,124,139,70},{49,43,50,56,61,55},{50,44,51,57,62, 56},{51,45,52,58,63,57},{52,46,53,59,64,58},{53,47,54,60,65,59},{54,48, 137,128,127,126,138,60},{178,186,179,171,162,170},{179,187,180,172,163, 171},{180,188,181,173,164,172},{181,189,182,174,165,173},{182,190,183,175, 166,174},{183,191,184,176,167,175},{184,192,185,177,168,176},{193,200,194, 187,179,186},{194,201,195,188,180,187},{188,195,202,196,189,181},{189,196, 203,197,190,182},{190,197,204,198,191,183},{191,198,205,199,192,184},{206, 212,207,201,194,200},{102,103,104,245,193,186,178,244},{104,105,106,246, 206,200,193,245},{106,107,108,247,217,212,206,246},{108,109,110,248,226, 222,217,247},{110,111,112,249,233,230,226,248},{112,113,114,250,238,236, 233,249},{131,132,133,260,169,177,185,259},{129,130,131,259,185,192,199, 258},{127,128,129,258,199,205,211,257},{125,126,127,257,211,216,221,256},{ 123,124,125,256,221,225,229,255},{121,122,123,255,229,232,235,254},{226, 230,227,223,218,222},{227,231,228,224,219,223},{228,232,229,225,220,224},{ 207,213,208,202,195,201},{208,214,209,203,196,202},{209,215,210,204,197, 203},{210,216,211,205,198,204},{217,222,218,213,207,212},{218,223,219,214, 208,213},{219,224,220,215,209,214},{220,225,221,216,210,215}}, {{2.,1.},{4.,1.},{6.,1.},{8.,1.},{10., 1.},{12.,1.},{14.,1.},{16.,1.},{18.,1.},{2.,2.},{4.,2.},{6.,2.},{8., 2.},{10.,2.},{12.,2.},{14.,2.},{16.,2.},{18.,2.},{3.,2.},{5.,2.},{7., 2.},{9.,2.},{11.,2.},{13.,2.},{15.,2.},{17.,2.},{3.,3.},{5.,3.},{7., 3.},{9.,3.},{11.,3.},{13.,3.},{15.,3.},{17.,3.},{4.,3.},{6.,3.},{8., 3.},{10.,3.},{12.,3.},{14.,3.},{16.,3.},{4.,4.},{6.,4.},{8.,4.},{10., 4.},{12.,4.},{14.,4.},{16.,4.},{5.,4.},{7.,4.},{9.,4.},{11.,4.},{13., 4.},{15.,4.},{5.,5.},{7.,5.},{9.,5.},{11.,5.},{13.,5.},{15.,5.},{6., 5.},{8.,5.},{10.,5.},{12.,5.},{14.,5.},{6.,6.},{8.,6.},{10.,6.},{12., 6.},{14.,6.},{7.,6.},{9.,6.},{11.,6.},{13.,6.},{7.,7.},{9.,7.},{11., 7.},{13.,7.},{8.,7.},{10.,7.},{12.,7.},{8.,8.},{10.,8.},{12.,8.},{9., 8.},{11.,8.},{9.,9.},{11.,9.},{10.,9.},{10.,10.},{11.,1.},{21.,1.},{1.5, 2.},{2.5,3.},{3.5,4.},{4.5,5.},{5.5,6.},{6.5,7.},{7.5,8.},{8.5,9.},{1.5, 11.5},{2.,11.5},{2.5,11.5},{3.,11.5},{3.5,11.5},{4.,11.5},{4.5,11.5},{ 5.,11.5},{5.5,11.5},{6.,11.5},{6.5,11.5},{7.,11.5},{7.5,11.5},{8., 11.5},{8.5,11.5},{9.,11.5},{11.,11.5},{11.5,11.5},{12.,11.5},{12.5, 11.5},{13.,11.5},{13.5,11.5},{14.,11.5},{14.5,11.5},{15.,11.5},{15.5, 11.5},{16.,11.5},{16.5,11.5},{17.,11.5},{17.5,11.5},{18.,11.5},{18.5, 11.5},{19.,11.5},{20.,11.5},{18.5,2.},{17.5,3.},{16.5,4.},{15.5,5.},{ 14.5,6.},{13.5,7.},{12.5,8.},{11.5,9.},{1.,1.},{1.,11.5},{9.,10.},{11., 10.},{0,0},{21.,0},{11.,0},{0,23.},{21.,23.},{2.,22.},{4.,22.},{6., 22.},{8.,22.},{10.,22.},{12.,22.},{14.,22.},{16.,22.},{18.,22.},{2., 21.},{4.,21.},{6.,21.},{8.,21.},{10.,21.},{12.,21.},{14.,21.},{16., 21.},{18.,21.},{3.,21.},{5.,21.},{7.,21.},{9.,21.},{11.,21.},{13.,21.},{ 15.,21.},{17.,21.},{3.,20.},{5.,20.},{7.,20.},{9.,20.},{11.,20.},{13., 20.},{15.,20.},{17.,20.},{4.,20.},{6.,20.},{8.,20.},{10.,20.},{12., 20.},{14.,20.},{16.,20.},{4.,19.},{6.,19.},{8.,19.},{10.,19.},{12., 19.},{14.,19.},{16.,19.},{5.,19.},{7.,19.},{9.,19.},{11.,19.},{13., 19.},{15.,19.},{5.,18.},{7.,18.},{9.,18.},{11.,18.},{13.,18.},{15., 18.},{6.,18.},{8.,18.},{10.,18.},{12.,18.},{14.,18.},{6.,17.},{8.,17.},{ 10.,17.},{12.,17.},{14.,17.},{7.,17.},{9.,17.},{11.,17.},{13.,17.},{7., 16.},{9.,16.},{11.,16.},{13.,16.},{8.,16.},{10.,16.},{12.,16.},{8., 15.},{10.,15.},{12.,15.},{9.,15.},{11.,15.},{9.,14.},{11.,14.},{10., 14.},{10.,13.},{0,22.},{1.,21.},{2.,20.},{3.,19.},{4.,18.},{5.,17.},{6., 16.},{7.,15.},{8.,14.},{9.,13.},{11.,13.},{12.,14.},{13.,15.},{14., 16.},{15.,17.},{16.,18.},{17.,19.},{18.,20.},{19.,21.},{20.,22.}}]; MapAprilFoolsHarder = PlanarMap[Append[ ReplacePart[ Append[ReplacePart[MapAprilFools[[1]], {149, 262, 263, 7,6, 91},37],{262,148,92,9,8,263}], {265,264,155,156,157,158,159,160,261,134,133,132,135,18,9,92,151}, 29], {264, 265, 150,242,152,153,154}] /. { {7,8,17,25,16} -> {7,263,8,17,25,16}, {163,172,164,155,154}-> {163,172,164,155,264,154}}, Join[MapAprilFools[[2]], N@{{15,0},{15,1}, {7,22}, {7,23}}]]; (*MapAprilFoolsHardest = PlanarMap[ Join[MapAprilFoolsHarder[[1]], {{266,267,268,269, 150,265,151,92,148,262,149,147,242, 150, 269}}], Join[MapAprilFoolsHarder[[2]], {{-1,-1}, {22,-1}, {22,24}, {-1,24}}]];*) IntersectOpen[{a_,b_},{c_,d_}]:= ((LeftOf[a,b,c] && RightOf[a,b,d]) || (LeftOf[a,b,d] && RightOf[a,b,c])) && ((LeftOf[c,d,a] && RightOf[c,d,b]) || (LeftOf[c,d,b] && RightOf[c,d,a])) Options[PathDecomposition] = {ShowTriangles->False}; PathDecomposition[poly_, opts___Rule] := PathDecomposition[poly, Range[Length[poly]], opts] PathDecomposition[poly1_, bords_List, opts___Rule] := Module[{n = Length[poly1], m, k, triangle, triborder, offset = 0, poly = MakeCounterclockwise[poly1]}, stQ = ShowTriangles /. {opts} /. Options[PathDecomposition]; borders = Sort[bords /. All -> Range[n]]; m = Length[borders]; Clear[StarShapedQ]; tris = Sort[Triangulate[poly], SignedArea[poly[[#1]]] > SignedArea[poly[[#2]]]&]; StarShapedQ[poly_] := Module[{c, aa = {False,0}, edges = Partition[extend[poly],2,1]}, c = Centroid[poly[[#]]] & /@ tris; ss = Select[c, Function[pt, And @@ Flatten @ Delete[Table[ (!IntersectOpen[{pt, 0.5 Plus @@ poly[[{borders[[i]],borders[[i]]+1 /. n+1 -> 1}]]},#]) & /@ edges,{i,Length[borders]}], Table[{i, borders[[i]]}, {i, Length[borders]}]]], 1]; If[ss == {}, aa, {True, First[ss]}]]; If[(ssq = StarShapedQ[poly])[[1]], capital = N@ssq[[2]]; ans = Table[{}, {m}], Clear[triangle]; triangle[ed_] := First@Select[Range[Length[tris]], MemberQ[Partition[extend[tris[[#]]],2,1], ed]&, 1]; capital = N@Centroid[poly[[tris[[1]]]]]; gr = Graph[Outer[ If[Length[Intersection[#1,#2]] > 1, 1,0]&, tris,tris,1],Centroid[poly[[#]]]& /@ tris]; pathdata = Map[ShortestPath[gr, 1, triangle[{#,#+1 /. n+1 -> 1}]]&, borders]; (* tricky programming here to make sure the branches in the triangle tree start at an appropriate point *) offset = Position[pathdata, If[MemberQ[Length /@ pathdata, 1], First@Select[pathdata, Length[#]==1&,1], s=Select[pathdata, #[[2]] != pathdata[[1,2]]&,1]; If[s=={}, common = pathdata[[1,{1,2}]]; critical = First@First@Select[Partition[extend[tris[[common[[1]]]]],2,1], MemberQ[edgesSorted[tris[[common[[2]]]]],Sort[#]]&,1]; ss=Select[borders, # >= critical&,1]; If[ss=={}, pathdata[[1]], pathdata[[Position[borders,ss[[1]]][[1,1]]]]], First[s]] ]][[1,1]]-1; pathdata = Partition[#,2,1]& /@ RotateLeft[pathdata,offset]; crossings = Transpose[{Union[Flatten[pathdata, 1]], Length /@ Split[Sort[Flatten[pathdata,1]]]}]; Clear[k, triborder]; k[i_,j_] := 0; triborder[i_, j_, k_,m_] := ( N[{1-k/m, k/m}].poly[[First@Select[ Partition[extend@tris[[i]],2,1], MemberQ[edgesSorted[tris[[j]]], Sort[#]] &, 1]]]); ans = pathdata //. {i_Integer, j_Integer} :> (k[i,j]++; triborder[i,j,k[i,j], 1+Select[crossings, First[#] == {i,j}&, 1][[1,-1]]])]; If[stQ,Show[Graphics[{Thickness[0.007], { {GrayLevel[Random[Real, {0.5, 1}]], Polygon[poly[[#]]]}, Thickness[0.005], GrayLevel[0.2], Line[poly[[#]]]}& /@ tris,Line@extend@poly, MapIndexed[{Hue[Random[Real, {.2, 0.8}]],Line@Join[{capital},#1, {0.5 Plus @@ poly[[Mod[borders[[ Mod[offset + #2[[1]],m] /. 0 -> m]]+{0,1},n]/. 0->n]]} ]}&, ans], {PointSize[0.02], Blue, Point /@ poly, Red, Point /@ ((poly + RotateLeft[poly])/2)}, {PointSize[0.03], Point[capital]} }],AspectRatio->Automatic, Background->RGBColor[1,1,0.5], Frame->True, FrameTicks->None, DefaultColor->Black]]; {capital,RotateRight[MapIndexed[Join[#1, {0.5 Plus @@ poly[[Mod[borders[[ Mod[offset + #2[[1]],m] /. 0 -> m]]+{0,1},n]/. 0->n]]} ]&, ans], offset]}] Unprotect[ShowGraph]; fixMat[m_, sym_:Graph] := Table[If[ ListQ[m[[j,i]]] && !ListQ[m[[i,j]]], If[sym===MultiGraph, Reverse /@ m[[j,i]], Reverse @ m[[j,i]]], m[[i,j]]], {i, Length[m]}, {j, Length[m]}] (* this draws a graph in the case that the adjacency matrix has piecewise linear info for edges *) UnProtect[ShowGraph]; ShowGraph[PlanarGraphPL[mat_, pts_], opts___] := Module[ {mat2 = fixMat[mat], n = Length[pts]}, {vs, vc, es} = {VertexSize, VertexColor, EdgeStyle} /. {opts} /. Options[ShowGraph]; vs = vs /. Automatic -> PointSize[Which[ n <= 12, 0.035, n <= 25, 0.022, n <= 100, 0.018, True, 0.01]]; If[!ListQ[es], es = {es}]; Show[Graphics[{ Join[es,Map[Line, DeleteCases[Flatten[ Table[Which[ mat2[[i,j]] === 0, {}, mat2[[i,j]] === 1, pts[[{i,j}]], True, Join[{pts[[i]]}, mat2[[i,j]], {pts[[j]]}]], {i, Length[pts]}, {j,i+1, Length[pts]}],1],{}]]], Join[{vs,vc},Point /@ pts]}, FilterOptions[Graphics,opts]]]] ShowGraph[MultiGraph[mat_, pts_], opts___] := Module[ {mat2 = fixMat[mat, MultiGraph], n = Length[pts]}, {vs, vc, es} = {VertexSize, VertexColor, EdgeStyle} /. {opts} /. Options[ShowGraph]; vs = vs /. Automatic -> PointSize[Which[ n <= 12, 0.035, n <= 25, 0.022, n <= 100, 0.018, True, 0.01]]; If[!ListQ[es], es = {es}]; Show[Graphics[{ Join[es, Table[Which[ mat2[[i,j]] === 0, {}, mat2[[i,j]] === 1, Line@pts[[{i,j}]], True, Line@Join[{pts[[i]]}, #, {pts[[j]]}]& /@ mat2[[i,j]]], {i, Length[pts]}, {j,i+1, Length[pts]}]], Join[{vs,vc},Point /@ pts]}, FilterOptions[Graphics,opts]]]] Protect[ShowGraph]; Options[AdjacencyGraph] = {StraightenEdges -> False, RepeatedStraightenings -> False}; AdjacencyGraph[PlanarMap[faces_, pts_], opts___] := Module[{n}, countries = pts[[#]]& /@ faces; n = Length[faces]; Clear[nbrs, borderindex, borderpt]; {strQ, repQ} = {StraightenEdges, RepeatedStraightenings} /. {opts} /. Options[AdjacencyGraph]; borderpt[i_, j_] := 1/2 Plus @@ (First[Intersection @@(edgesSorted /@ countries[[{i,j}]])]); nbrs[i_] := nbrs[i]=Select[Range[n], # != i && 1 == adjacent[faces[[i]],faces[[#]]]&]; borderindex[i_,j_] := borderindex[i,j] = (int = First[Intersection[ edgesSorted[faces[[i]]], edgesSorted[faces[[j]]]]]; First@Flatten[{ Position[Partition[extend@faces[[i]],2,1],int], Position[Partition[extend@faces[[i]],2,1], Reverse@int]}]); bigpathdata = Table[ PathDecomposition[countries[[i]],Sort[borderindex[i,#]& /@ nbrs[i]]], {i,n}]; If[repQ || strQ, If[repQ, FixedPoint[Function[v,Straighten[v,countries]], #] &, Straighten[#,countries]&], Identity][PlanarGraphPL[ Table[If[(j <= i) || (adjacent[faces[[i]], faces[[j]]] == 0), 0, Join[ bigpathdata[[i,2, (Position[Sort[borderindex[i,#]& /@ nbrs[i]], borderindex[i,j]] [[1,1]])]]/. 0->Length[bigpathdata[[i,2]]], Rest @ Reverse[ bigpathdata[[j, 2, Mod[( (Position[Sort[borderindex[j,#]& /@ nbrs[j]], borderindex[j,i]][[1,1]])),Length[bigpathdata[[j,2]]]]/. 0->Length[bigpathdata[[j,2]]] ]]] ]], {i,Length[faces]}, {j,Length[faces]}], First /@ bigpathdata]] ] Unprotect[InduceSubgraph]; InduceSubgraph[g_PlanarGraphPL,{}] := PlanarGraph[{},{}] InduceSubgraph[PlanarGraphPL[g_,v_],s_List] := PlanarGraphPL[Transpose[Transpose[g[[s]]] [[s]] ],v[[s]]] /; (Length[s]<=Length[g]) Protect[InduceSubgraph] ToGraph[PlanarGraphPL[mat_, p_]] := Module[{z,mm}, Graph[ mm=(Apply[z, mat, {0,1}] /. x_List :> 1 /. z->List); Sign[mm+Transpose[mm]],p]]; KempeOrder[PlanarGraphPL[g_]] := KempeOrder[ToGraph[g]] MakePointsCounterclockwise[pts_, refpts_, offset_] := (refpts1 = refpts; Do[If[!ListQ[refpts[[i]]], refpts1[[i]] = pts[[i]]], {i, Length[refpts]}]; pts[[Position[refpts1,#][[1,1]]& /@ Sort[N[refpts1], Arg[Complex @@ (#1-offset)] < Arg[Complex @@ (#2-offset)]&]]]) Options[FourColoringPL] = {MaxTries -> 100, Precolored->{}, Method -> Kempe}; FourColoringPL[gg_PlanarGraphPL, opts___] := Module[{cols, mx}, matraw = gg[[1]]; Do[If[j < i && ListQ[matraw[[j,i]]], matraw[[i,j]]=Reverse@matraw[[j,i]]], {i, Length[gg[[1]]]}, {j, Length[gg[[1]]]}]; g1 = PlanarGraphPL[matraw, gg[[2]]]; g = ToGraph[g1]; order = KempeOrder[g]; kem = 1; fc = {}; {pre, met, mx} = {Precolored, Method, MaxTries} /. {opts} /.Options[FourColoringPL]; cols = Last /@ pre; len = Length[pre]; Do[ nbrs = Neighbors[ InduceSubgraph[g, Take[order,{-j,-1}]], 1]-1; If[Length[Union[cols[[nbrs]]]] < 4, cols = Flatten[{First[Complement[Range[4], cols[[nbrs]]]], cols}], (* else go into Kempe Chain mode *) gadj = ToAdjacencyLists[ InduceSubgraph[g, Take[order, {-j+1,-1}]]]; pts = N[(gsubgr = InduceSubgraph[g1, Take[order, {-j,-1}]])[[ 2, Prepend[nbrs+1,1]]]]; nbrs = nbrs[[Flatten[(Position[Rest[pts], #]& /@ (MakePointsCounterclockwise[Rest[pts], First /@ (gsubgr[[1,1]][[nbrs+1]] /. {1 -> {1}, 0 -> {0}}), First[pts]]))]]]; If[Length[nbrs] == 4, fc1 = KempeChain[nbrs[[{1,3}]], cols]; fc = If[fc1 =!= False, fc1, fc2 = KempeChain[nbrs[[{2,4}]], cols]; If[fc2 =!= False, fc2, Message[FourColoring::subdv]; Return[$Failed]]], (* so now vertex degree must be 5 and 4 colors in ring with 1 repeat *) If[met === KittellOnly, icount = 0; Do[icount++; w = nbrs[[Random[Integer, {1,5}]]]; c1 = DeleteCases[Range[4], cols[[w]]][[ Random[Integer, {1,3}]]]; If[Length[Union[cols[[nbrs]]]] < 4, Break[]]; v = Select[nbrs, cols[[#]] == c1 &]; cols = KempeSwitch[{w,v}, cols, AlgorithmTrace -> traceQ]; If[traceQ, Scan[(tracecols = ReplacePart[tracecols, cols[[j-#]], {order[[-#]]}])&, Range[j-1]]], {i, mx}]; If[kittrace, Print[StringForm["`` random Kempe switches were needed to resolve the impasse.",icount]]]; fc=If[icount == mx, $Failed, cols], nbrsColors = cols[[nbrs]];(* find colors in ring *) dupColor = First[Select[nbrsColors, Count[nbrsColors, #] == 2 &,1]]; samecolorNbrs = Select[nbrs,cols[[#]]==dupColor &,2]; samecolorIndices = Sort[Flatten[ Position[nbrs, #] & /@ samecolorNbrs]]; If[MemberQ[{1,4}, Abs[Subtract @@ samecolorIndices]], (* case adjacent *) v1 = samecolorIndices/.{{1,5}->1, {m_,n_} :> n}; v3 = First[DeleteCases[samecolorIndices, v1]]; v2 = v1 + 2; fc1 = KempeChain[{nbrs[[ mod5Fix[v2]]],nbrs[[mod5Fix /@ {v1,v3}]]}, cols]; fc = If[fc1 =!= False, fc1, KempeChain[ nbrs[[mod5Fix /@ {v1+1,v2+1}]], cols]], (* split case *) v1 = (samecolorIndices /. {{1,4} -> 1, {2,5}->2, {m_, n_} :> n}) - 1; v2 = v1 + 2; fc1 = KempeChain[nbrs[[mod5Fix /@ {v1,v2}]], cols]; fc = If[fc1 =!= False, fc1, fc1 = KempeChain[ nbrs[[mod5Fix/@{v1,v2+1}]],cols]; If[fc1 =!= False, fc1, fc1 = KempeChain[ nbrs[[mod5Fix /@{v1+1,v2+1}]], cols]; If[fc1 === False, Message[FourColoring::subdv];Return[$Failed], fc2 = KempeChain[nbrs[[mod5Fix /@ {v1-1, v2}]], fc1]; If[fc2 =!= False, fc2, If[met =!= Kittell, Message[FourColoring::failed];Return[$Failed], (* otherwise try Kittell's method *) icount = 0; cols = fc1; Do[icount++; w = nbrs[[Random[Integer, {1,5}]]]; c1 = DeleteCases[Range[4], cols[[w]]][[ Random[Integer, {1,3}]]]; If[Length[Union[cols[[nbrs]]]] < 4, Break[]]; v = Identity[Select[nbrs, cols[[#]] == c1 &]]; cols = KempeSwitch[{w,v}, cols], {i, mx}]; If[icount == mx, $Failed, cols]] ]] ]] ] (* End If for 2 cases *) ]]; If[fc =!= $Failed, cols = Flatten[ {First[Complement[Range[4], fc[[nbrs]]]], fc}]]], {j, len+1, V[g]}]; If[fc === $Failed, fc, cols[[InversePermutation[order]]]]] Straighten[p_PlanarGraphPL, polys_] := Module[{mat = fixMat[p[[1]]], n = Length[p[[1]]]}, Do[If[ListQ[mat[[i,j]]], mat[[i,j]] = Rest[Drop[ reduceTriples[ Join[{p[[2,i]]}, mat[[i,j]], {p[[2,j]]}], Function[{v1,v2}, Length@Select[Union[ edgesSorted[polys[[i]]],edgesSorted[polys[[j]]]], (IntersectClosed[#, {v1,v2}] &)] <= 1 && {} == Select[Join @@ MapIndexed[If[!ListQ[#1] || #2 == {j}, {}, Partition[Join[{p[[2,i]]}, #1, {p[[2,#2[[1]]]]}],2,1]]&, mat[[i]]], (IntersectOpen[#, {v1,v2}])&] && {} == Select[Join @@ MapIndexed[If[!ListQ[#1] || #2 == {i}, {}, Partition[ Join[{p[[2,j]]}, #1, {p[[2,#2[[1]]]]}],2,1]]&, mat[[j]]], (IntersectOpen[#, {v1,v2}])&] ] ], -1]] /. {} -> 1; mat[[j,i]] = If[ListQ[mat[[i,j]]], Reverse, Identity][mat[[i,j]]]],{i, n},{j,i+1,n}]; PlanarGraphPL[mat, p[[2]]]] (* The next function takes a list and a query function and replaces triples {x,y,z} by {x,z} when c[x,z] is true. It is used to straighten piecewise linear edges in the dual graph. *) reduceTriples[l_, c_] := l /; Length[l] < 3; reduceTriples[l_, c_] := Join[{First[l]}, reduceTriples[Rest[l],c]] //.{s_, t_, u_, v___} :> If[c[s,u], {s,u, v}, {s,t,u,v}] /; Length[l] > 2 InducedSubmap[PlanarMap[faces_,pts_], countries_] := ( subset = pts[[Union @@ faces[[countries]]]]; fac=faces[[ countries]]/. n_Integer :> Position[subset, pts[[n]]][[1,1]]; PlanarMap[ If[Orientation[subset[[#]]]==-1, Reverse[#], #]& /@ fac, subset]); BorderEdges[PlanarMap[c_, _]] := Module[{edges}, edges = Join @@ edgesSorted /@ c; Select[Union[edges], Count[edges, #] == 1 & ]] BorderCountries[PlanarMap[c_, p_]] := Flatten[(Position[c, #] & ) /@ Select[c, Intersection[BorderEdges[PlanarMap[c, p]], edgesSorted[#]] != {} & ]] Boundary[PlanarMap[c_, p_]] := (borderedges = BorderEdges[PlanarMap[c, p]]; edgeGr = Graph[Array[If[#1 != #2 && Intersection[borderedges[[#1]], borderedges[[#2]]] != {}, 1, 0] & , {Length[borderedges], Length[borderedges]}], borderedges]; cy = FindCycle[edgeGr]; ans = p[[Flatten[MapIndexed[Select[#1, Function[i, MemberQ[borderedges[[cy]][[1 + #2[[1]] /. Length[borderedges] + 1 -> 1]], i]]] & , borderedges[[Drop[cy, -1]]]]]]]; If[Orientation[ans] == 1, Identity, Reverse][ans]) AddExteriorFace[PlanarMap[c_, p_]] := (b = Boundary[PlanarMap[c, p]]; inside = RotateLeft[b, Position[b, Sort[b][[1]]][[1,1]] - 1]; insideind = RotateRight[Reverse@ Flatten[(Position[p, #1] & ) /@ inside],1]; pr = PlotRange[Show[Graphics[Point /@ p], DisplayFunction -> Identity]]; dels = 1/10*{pr[[1,2]] - pr[[1,1]], pr[[2,2]] - pr[[2,1]]}; pr = {{pr[[1,1]] - dels[[1]], pr[[1,2]] + dels[[1]]}, {pr[[2,1]] - dels[[2]], pr[[2,2]] + dels[[2]]}}; PlanarMap[Append[c, Join[Length[p] + {1, 2, 3, 4, 1}, insideind, {insideind[[1]]}]], Join[p, {pr[[{1, 2},1]], {pr[[1,2]], pr[[2,1]]}, pr[[{1, 2},2]], {pr[[1,1]], pr[[2,2]]}}]]) Options[ShowTableGC] = { ColumnHeadings -> None, RowHeadings -> None, HeadingFontWeight -> Bold, HeadingFontColor->RGBColor[0,0,0], HeadingFontSize->10}; ShowTableGC[x_, opts___] := Module[ {data = x, head, h, chead, rhead, hfw, hfc, hsz}, {chead, rhead,hfw,hfc,hsz} = {ColumnHeadings, RowHeadings, HeadingFontWeight, HeadingFontColor, HeadingFontSize} /. {opts} /. Options[ShowTableGC]; data = Map[MakeBoxes[#, StandardForm]&, data,{2}]; h[s_] := (StyleBox[MakeBoxes[#, StandardForm] & @ s, FontWeight->hfw, FontColor->hfc, FontSize->hsz]); {chead1, rhead1} = Map[h, {chead, rhead}, {2}]; data = If[chead =!= None, Prepend[data, chead1], data]; data = If[rhead === None, data, Transpose[ Prepend[Transpose[data], If[chead === None, rhead1, Prepend[rhead1, ""]]]]]; DisplayForm[StyleBox[ GridBox[data, GridFrame -> 2, RowLines -> If[chead === None, 1, {2,1}], ColumnLines -> 1, ColumnAlignments->Right, FilterOptions[GridBox, opts]], Sequence @@ (Select[{opts}, MemberQ[{Background, FontFamily, FontWeight, FontSize, FontColor}, First[#]]&]), Background -> RGBColor[1, 1, 0.6], FontFamily -> "Times", FontSize->10]]] Straighten[p_MultiGraph, polys_] := Module[{mat = fixMat[p[[1]], MultiGraph], n = Length[p[[1]]]}, data = DeleteCases[ DeleteCases[ Flatten[MapIndexed[(Function[w,{#2,w}] /@ #1) &, mat /. 1 -> {{}},{2}],2] , 0], _?(#[[1,1]] >= #[[1,2]] &)]; Do[ {i,j} = data[[k,1]]; data[[k]] = {data[[k,1]], Rest[Drop[ reduceTriples[ Join[{p[[2,i]]}, data[[k,2]], {p[[2,j]]}], Function[{v1,v2}, (Length[Select[Union[ edgesSorted[polys[[i]]],edgesSorted[polys[[j]]]], (IntersectClosed[#, {v1,v2}] &),2]]) <= 1 && (tempEdges = Join @@ (Partition[ Join[{p[[2,#[[1,1]]]]}, #[[2]], {p[[2,#[[1,2]]]]}],2,1] & /@ Select[data, #[[1,1]] == i || #[[1,2]] == i || #[[1,1]] == j || #[[1,2]] == j &]); {} == Select[ tempEdges, ((# == {v1, v2}) || (# == {v2,v1}) || IntersectOpen[#, {v1,v2}])&, 1]) ] ],-1]]},{k, Length[data]}]; Scan[(mat=ReplacePart[mat, {}, #[[1]]]; mat=ReplacePart[mat, {}, Reverse[#[[1]]]]) &, data]; Scan[(mat=ReplacePart[mat, Flatten[{mat[[#[[1,1]], #[[1,2]]]], {#[[2]]}},1], #[[1]]]; mat= ReplacePart[mat, Flatten[{mat[[#[[1,2]], #[[1,1]]]], {Reverse[#[[2]]]}},1], Reverse[#[[1]]]]) &, data]; MultiGraph[mat, p[[2]]]] borderindices[i_,j_] := borderindices[i,j] = (int = Intersection[ edgesSorted[faces[[i]]], edgesSorted[faces[[j]]]]; Flatten[{ Position[Partition[extend@faces[[i]],2,1],#]&/@int, Position[Partition[extend@faces[[i]],2,1],Reverse@#]& /@ int}]); Options[DualMultiGraph] = {StraightenEdges -> False, RepeatedStraightenings -> False}; DualMultiGraph[m_PlanarMap, opts___] := Module[{n}, {faces,pts} = List @@ AddExteriorFace[m]; countries = pts[[#]]& /@ faces; n = Length[faces]; Clear[nbrs, borderindex, borderpt]; {strQ, repQ} = {StraightenEdges, RepeatedStraightenings} /. {opts} /. Options[DualMultiGraph]; borderpt[i_, j_] := 1/2 Plus @@ (First[Intersection @@(edgesSorted /@ countries[[{i,j}]])]); nbrs[i_] := nbrs[i]=Select[Range[n], # != i && 1 == adjacent[faces[[i]],faces[[#]]]&]; Clear[borderindices, allborderindices]; borderindices[i_,j_] := ( borderindices[i,j] = (int = Select[ edgesSorted[faces[[i]]],MemberQ[ edgesSorted[faces[[j]]],#]&]; Flatten[{ Position[Partition[extend@faces[[i]],2,1],#]&/@int, Position[Partition[extend@faces[[i]],2,1],Reverse@#]& /@ int}])); allborderindices[i_] := allborderindices[i] = Sort[Flatten[borderindices[i,#]& /@ nbrs[i]]]; bigpathdata = Table[ PathDecomposition[countries[[i]],allborderindices[i]], {i,n}]; If[repQ || strQ, If[repQ, FixedPoint[Function[v,Straighten[v,countries]], #] &, Straighten[#,countries]&], Identity][MultiGraph[ Table[ sss=allborderindices[i] /. nn_Integer :> (Select[DeleteCases[Range[n],i], MemberQ[edgesSorted[faces[[#]]], Sort@faces[[i,{nn,nn+1}/. 1+Length[faces[[i]]] -> 1]]]&,1][[1]]); Table[ If[(j <= i) || (adjacent[faces[[i]], faces[[j]]] == 0), 0, iter = Flatten[Position[sss,j]]; Table[ Join[bigpathdata[[i,2,iter[[k]]]], Rest@Reverse@bigpathdata[[j,2, Position[allborderindices[j], Position[faces[[j]], faces[[i,allborderindices[i][[iter[[k]]]]]]][[-1,1]]-1 /. 0->Length[faces[[j]]]][[1,1]]]]], {k,Length[iter]}]], {j,n}], {i,n}], First /@ bigpathdata]] ] Clear[MultiGraphToGraph]; MultiGraphToGraph[MultiGraph[mat_,p_]] := ( newpts = Union @ Cases[mat, {x_?NumericQ, y_}, Infinity]; pts = Join[p, newpts]; n = Length[mat]; l = Length[newpts]; mat4 = Array[(p1=Position[mat, newpts[[#1]]][[1]]; p2=Position[mat, newpts[[#2]]][[1]]; If[p1[[{1,2,3}]] == p2[[{1,2,3}]] && Abs[p1[[-1]]-p2[[-1]]]==1,1,0])&, {l, l}]; mat1 = Table[mat[[i,j]] /. {{} -> 1, x_List?(!MemberQ[#, {}]&) :> 0, x_List?(MemberQ[#, {}]&) :> 1}, {i,n},{j,n}]; mat2 = Array[(p1 = Position[mat, newpts[[#2]]][[1]]; If[(p1[[1]] == #1 && p1[[4]] == 1) || (p1[[2]] == #1 && p1[[4]] == Length[mat[[p1[[1]], p1[[2]], p1[[3]]]]]),1,0])&, {Length[mat], l}]; PlanarGraph[Join[ Thread[fcn[mat1, mat2]] /. fcn->Join, Thread[fcn[Transpose[mat2], mat4]] /. fcn->Join], pts]) FirstNeighbor[g_,l_List] := l /; Last[l] == First[l] FirstNeighbor[g_,l_Integer] := {l,First[Neighbors[g,l]]} FirstNeighbor[g_,{l_Integer}] := FirstNeighbor[g,l] FirstNeighbor[g_,l_List] :=Module[{p}, ss=Union[Neighbors[g,l[[-1]]],{l[[-2]]}]; If[ss=={}, ss, (p=Flatten[Position[g[[2]], #] & /@ MakePointsCounterclockwise[g[[2, ss]],g[[2,l[[-1]]]]]]; Flatten[{l,p[[(Position[p,l[[-2]]][[1,1]] - 1) /. 0->Length[p]]]}])]] /; Length[l]>1 bad[map_,face_] :=(Clear[ff]; If[Length[Union[face]] != Length[face], Return[True]]; tris = Triangulate[map[[2,face]]] /. n_Integer :> face[[n]]; ff = Function[pt, Or @@ Map[Inside[map[[2,#]],pt]&, tris]]; Length[Select[map[[2]], ff]] > Length[face]) PlanarGraphToPlanarMap[g_PlanarGraph] := Module[{l={},p}, gra = Graph @@ g; While[(p = Position[gra[[1]],1]) != {}, AppendTo[l, cy = FixedPoint[FirstNeighbor[gra, #]&, p[[1,1]]]]; gra = DeleteCycle[gra,cy,Directed]]; m1 = PlanarMap[If[Orientation[g[[2,Rest[#]]]]==-1, Reverse[Rest[#]], Rest[#]]& /@ l, g[[2]]]; badface = Select[m1[[1]], bad[m1,#]&]; If[badface == {}, m1, PlanarMap[DeleteCases[m1[[1]], badface[[1]]],m1[[2]]]]] PlanarGraphPLToGraph[PlanarGraphPL[m_,p_]] := ( newpts = Union @ Cases[m, {x_?NumericQ,y_}, Infinity]; pts = Join[p,newpts]; mat4 = Array[(p1=Position[m, newpts[[#1]]][[1]]; p2=Position[m, newpts[[#2]]][[1]]; If[p1[[{1,2}]] == p2[[{1,2}]] && Abs[p1[[-1]]-p2[[-1]]]==1,1,0])&, {Length[newpts],Length[newpts]}]; mat1 = Table[m[[i]] /. x_List?(ListQ[#[[1]]] && NumericQ[#[[1,1]]]&):>0, {i,Length[m]}]; mat2 = Array[(p1 = Position[m, newpts[[#2]]][[1]]; If[(p1[[1]] == #1 && p1[[3]] == 1) || (p1[[2]] == #1 && p1[[3]] == Length[m[[p1[[1]],p1[[2]]]]]),1,0])&, {Length[m], Length[newpts]}]; PlanarGraph[Join[ Thread[fcn[mat1, mat2]] /. fcn->Join, Thread[fcn[Transpose[mat2], mat4]] /. fcn->Join], pts]); End[]; EndPackage[];