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:
   * The name of the vertex
   * The names of the vertices that are connected to it

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]"

----
[[
[Category Mathematics]
]]