3
$\begingroup$

This question already has an answer here:

I'm still wrestling with the following problem; I' m attempting to apply the Four Color Theorem to the map of Florida; USA. The attribute "BorderingCounties" doesn't work for Alachua County (but, it works for all other counties in Florida):

AdministrativeDivisionData[Entity["AdministrativeDivision", {"AlachuaCounty", "Florida", "UnitedStates"}], "BorderingCounties"]

gives: "Missing["UnknownEntity", {"AdministrativeDivision", {"AlachuaCounty", "Florida", "UnitedStates"}}]. Next; build the following set containing of all the counties in Florida:

    counties = 
  EntityList[
   EntityClass["AdministrativeDivision", "USCountiesFlorida"]];

Here is a list of the bordering counties for each county of Florida (except for Alachua County); and including some counties located in the States of Alabama and Georgia :

    borderingcounties = 
  AdministrativeDivisionData[#, "BorderingCounties"] & /@ counties;

Since evaluating;

 borderingcounties[[1]] 

gives: "Missing["UnknownEntity", {"AdministrativeDivision", {"AlachuaCounty", "Florida", "UnitedStates"}}]" ; we do the following "patchup":

    borderingcounties[[1]] = 
 Table[counties[[i]], {i, {4, 12, 20, 37, 41, 54, 63}}]

If you now evaluate:

 borderingcounties

you'll see that it now contains the desired counties.

Here is a map showing all the bordering counties. Notice that the map includes some counties located in Alabama and Georgia :

    GeoGraphics[{
  GeoStyling["OutlineMap", 
   Directive[Opacity[0.05], Yellow, EdgeForm[Black]]], 
  Polygon[borderingcounties], GeoStyling[]}, 
 GeoProjection -> "Equirectangular", Frame -> True]

Now build the following set that contains: each county in Florida; together with the corresponding bordering counties associated to each county; located exclusively in Florida :

    neighbors = 
  Table[{counties[[i]], 
    Intersection[borderingcounties[[i]], counties]}, {i, 1, 
    Length[counties]}];

(** Express the condition that all pairs of bordering countries have different colors as a logical expression: **)

 eqs = And @@ (Flatten[Function[{c, n}, BooleanConvert[Xor[x[c], x[#]] || Xor[y[c], y[#]], "CNF"] & /@ n] @@@ neighbors]);

(** Compute a solution to the four - color problem: **)

    solution = 
  Join[First[
    FindInstance[eqs, Union[Cases[eqs, _x | _y, \[Infinity]]], 
     Booleans]], 
   Flatten[{x[#] -> True, y[#] -> True} & /@ 
     Flatten[Cases[neighbors, {_, {}}]]]];

and the above evaluation is where I get in trouble since I get the following two warning messages after "solution" above is evaluated:

"First::nofirst:{}has zero length and no first element." and

"Join::heads: "Heads First and List at positions 1 and 2 are expected to be the same."

And since the evaluation of solution fails; the following three lines of code below also fail after they are evaluated:

(** Encode four colors as Boolean variables x and y: **)

 toColor[tf_] := <|{False, False} -> Red, {False, True} -> Blue, {True, False} -> Green, {True, True} -> Yellow|>[tf]

(** Form the coloring: **)

    coloring = (#[[1, 1, 1]] -> toColor[Last /@ #]) & /@ 
  Partition[SortBy[solution , #[[1, 1]] &], 2]

(** Color each county according to the coloring found: **)

    GeoGraphics[{EdgeForm[
   Directive[Thin, 
    Black]], {GeoStyling[#2], Tooltip[Polygon[#1], #1[[2]]]} & @@@ 
   coloring}]

The above should work as in the example provided in the Help section of the Wolfram Documentation; GeoGraphics; Neat Examples; "Find neighboring European countries" but, I can't figure out what is preventing the above code from working. Please, help me to figure out this problem! Thank you!

$\endgroup$

marked as duplicate by J. M. will be back soon Nov 13 '17 at 4:12

This question has been asked before and already has an answer. If those answers do not fully address your question, please ask a new question.