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
Attachments:
