ヨーロッパの地図の4色を求める 

ヨーロッパ各国の隣接国を求める．

In[1]:=

X countries = EntityList[EntityClass["Country", "EuropeSovereign"]]; countryneighbors = { #, Intersection[CountryData[#, "BorderingCountries"], countries] } & /@ countries;

以下はオーストリアの隣接国である．

In[2]:=

X First[countryneighbors]

Out[2]=

4つの色を1つの国につき2つのブール値として符号化する．

In[3]:=

X colorcode = { {False, False} -> Red, {False, True} -> Blue, {True, False} -> Green, {True, True} -> Yellow};

In[4]:=

X countrybooleans = # -> {x[#], y[#]} & /@ countries;

隣り合う国がすべて異なる色を持つような条件を論理式として表す．

In[5]:=

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

4色問題の解を計算する．

In[6]:=

X solution = First[FindInstance[eqs, Flatten[Last /@ countrybooleans], Booleans]];

色を付ける．

In[7]:=

X coloring = countrybooleans /. solution /. colorcode

Out[7]=

求めた色付けに従って各国に色を付ける．

In[8]:=

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

Out[8]=