if { 0 } { Arjen Markus (2 february 2004) The history of mathematics is filled with problems that seem easy but turn out to be devilishly complicated. One of these is the so-called four colours problem:
If you have a geographical map, how many colours do you need to colour each country in such a way that no two neighbouring countries have the same colour?
The answer is: 4.
But, if I remember correctly, it was the first theorem that was "proven" by the aid of a computer. Because the proof requires a lot of special cases.
Well, the theorem can be translated into a theorem about planar graphs - graphs that can be drawn without any edge crossing another one. And, it being game for mathematicians, it can be generalised to any kind of graph.
The script below takes a graph and determines whether it can be coloured with N colours in the above sense. The graph is given (that is a convenient format) as a list of pairs:
For instance the graph:
A ----> B ----> C | ^ v | D ------+
is represented by: {A {B D} B {C} D {B} C {}}
This graph can be coloured using three colours:
A -> green B -> red C -> green D -> blue green ----> red ----> green | ^ v | blue -------+
but not with two. }
# colour_graph.tcl --
# Determine whether a graph can be coloured with N colours
#
# DetermineColour --
# Determine the colour for the next node
#
# Arguments:
# coloured_nodes The nodes that have sofar been coloured
# number Number of available colours
# graph Description of the graph
# rest_nodes Nodes that still need to be coloured
# Result:
# 1 if we succeeded, 0 if not
# Note:
# The procedure is recursive - the first node can always be
# coloured with colour 0.
#
proc DetermineColour { coloured_nodes number graph rest_nodes } {
#
# Do we have anything left?
#
if { [llength $rest_nodes] == 0 } {
return 1
}
#
# Take the next node and give it a colour
#
set next [lindex $rest_nodes 0]
set rest_nodes [lrange $rest_nodes 1 end]
for { set i 0 } { $i < $number } { incr i } {
set new_colours [concat $coloured_nodes $next $i]
if { [ColourFits $new_colours $graph] } {
if { [DetermineColour $new_colours $number $graph $rest_nodes] } {
return 1
}
}
}
#
# No success ...
#
return 0
}
# ColourFits --
# Check that the new colour fits (no two neighbours
# with the same colour)
#
# Arguments:
# colours The nodes with their colours
# graph Description of the graph
# Result:
# 1 if okay, 0 if not
#
proc ColourFits { colours graph } {
#
# We only need to look at the last colour!
# All previous colours (if any have already been checked)
#
set new_node [lindex $colours end-1]
set new_colour [lindex $colours end]
foreach { node connections } $graph {
if { $node == $new_node } {
foreach c $connections {
set idx [lsearch $colours $c]
if { $idx >= 0 } {
set col [lindex $colours [incr idx]]
if { $col == $new_colour } {
return 0 ;# The colour already exists
}
}
}
} else {
if { [lsearch $connections $new_node] >= 0 } {
set idx [lsearch $colours $node]
if { $idx == -1 } {
return 1 ;# No colour yet for the node
} else {
set col [lindex $colours [incr idx]]
if { $col == $new_colour } {
return 0 ;# The colour already exists
}
}
}
}
}
#
# We found a new acceptable colour
#
puts "Colours: $colours"
return 1
}
# sufficientNumber --
# Determine if the number of colours is sufficient
#
# Arguments:
# number Number of available colours
# graph Description of the graph
# Result:
# 1 if we succeeded, 0 if not
#
proc sufficientNumber { number graph } {
set rest_nodes {}
foreach {node connections} $graph {
lappend rest_nodes $node
}
set coloured_nodes [concat [lindex $rest_nodes 0] "0"]
set rest_nodes [lrange $rest_nodes 1 end]
puts "Rest: $rest_nodes"
DetermineColour $coloured_nodes $number $graph $rest_nodes
}
# main --
# Main code (too lazy to write a general procedure)
#
# Note:
# The names of the nodes should not be numbers,
# otherwise the check must be made more complex.
#
set graph {A {B D} B {C} D {B} C {}}
puts "Graph: $graph"
puts "Number of colours = 1: [sufficientNumber 1 $graph]"
puts "Number of colours = 2: [sufficientNumber 2 $graph]"
puts "Number of colours = 3: [sufficientNumber 3 $graph]"
puts "Number of colours = 4: [sufficientNumber 4 $graph]"
set graph {A {B D C} B {C} D {B} C {}}
puts "Graph: $graph"
puts "Number of colours = 1: [sufficientNumber 1 $graph]"
puts "Number of colours = 2: [sufficientNumber 2 $graph]"
puts "Number of colours = 3: [sufficientNumber 3 $graph]"
puts "Number of colours = 4: [sufficientNumber 4 $graph]"
set graph {A {B D C} B {C} D {B} C {E F} E {A B} F {D}}
puts "Graph: $graph"
puts "Number of colours = 1: [sufficientNumber 1 $graph]"
puts "Number of colours = 2: [sufficientNumber 2 $graph]"
puts "Number of colours = 3: [sufficientNumber 3 $graph]"
puts "Number of colours = 4: [sufficientNumber 4 $graph]"