Message Boards Message Boards

GROUPS:

A solution to the Four-Color Theorem applied to the map Florida, USA

Posted 5 years ago
4882 Views
|
6 Replies
|
5 Total Likes
|

After struggling with this problem for a while (see initial efforts at: http://community.wolfram.com/groups/-/m/t/1078687 and http://community.wolfram.com/groups/-/m/t/1097057); I want to share a solution to this problem via the attached Mathematica workbook: "A solution to the Four-Color Theorem applied to the map Florida, USA.nb". The problem was not with the code itself but, with the way how the bordering counties for Okeechobee and Palm Beach are presently defined. If you remove Okeechobee from the list of bordering counties of Palm Beach (and vice versa) the code works.

Attachments:
6 Replies

Am I alone in not seeing any attached notebook (tried 2 browsers so far...) so I don't find any details at all of the solution! Thanks.

Posted 6 months ago

Hi Matthew,

You are not alone. Attachments to old posts are missing. The moderators are aware and said they were working on restoring them. That was several months ago and it seems the problem persists.

Moderators, can you please give us an update on the status of resolving this issue?

POSTED BY: Rohit Namjoshi

Thanks for the update Rohit, as is obvious, I was not aware there was any issue here. A bit surprising really, if this is truly a valued resource for the community! Good luck with getting it resolved. In the meantime, would it be possible to repost the solution here? All best, Matthew.

Sorry about the delay Matthew but, I'm recovering from a right foot ingrown toenail surgery. Indeed, the original "A solution to the Four-Color Theorem applied to the map Florida, USA.nb" notebook was lost due to a system glitch. Furthermore; I could not find this notebook among my CDs and DVDs where I store my files (and these have become a formidable bunch to peruse through after 5 years). Lucky for us; we have the following post located at: https://community.wolfram.com/groups/-/m/t/1078687 where Greg Hurst provides his amazing code to find a four-color map solution for the United States. He also mentions the "quintipoint" scenario (involving Palm Beach, Glades, Okeechobee, and neighboring counties) in Florida. If the quintipoint is not dealt with, then this omission interferes with finding a solution to the 4-color map for this state. What I'm doing next is modifying Greg Hurst's code, to find the 4-color solution for the map of Florida. I'm providing a new notebook: "A solution to the Four-Color Theorem applied to the map of Florida (Redux).nb" and a PDF version: "A solution to the Four-Color Theorem applied to the map of Florida (Redux).pdf" for those readers who might not have the Mathematica software readily available. I'm also providing the code below; just in case a future system glitch occurs.

florida = {DeleteCases[
 Entity["Country", "UnitedStates"][
  EntityProperty["Country", "AdministrativeDivisions"]], 
 s_ /; ! FreeQ[s, "Alaska" | "DistrictOfColumbia" | "Hawaii"]][[
8]]};

$triple = Entity["AdministrativeDivision", {"PalmBeachCounty" | 
 "GladesCounty" | "OkeechobeeCounty", "Florida", "UnitedStates"}];

counties = Join @@ (EntityList[
   EntityClass["AdministrativeDivision", 
    "USCounties" <> CanonicalName[#][[1]]]] & /@ Florida);

nassoc = EntityValue[counties, "BorderingCounties", "EntityAssociation"];

neighbors = {#, Intersection[nassoc[#] /. _Missing -> {}, counties]} & /@ counties;

neighbors = neighbors /. {c : $triple, n_} :> {c, DeleteCases[n, $triple]};

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

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

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

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

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

I hope this helps!

Thank you.

Gilmar Rodríguez-Pierluissi

Posted 6 months ago

Thanks so much Gilmar, that's great and I've downloaded the .nb with no trouble.

POSTED BY: Updating Name

You are welcome!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract