Libraries for Vicare Scheme: amb examples coloring

The following program shows how to select colors to paint European nations on map: given a map of nations we want to paint each nation with a color different from the one of its neighbors; it is known that 4 colors are always enough (even though more than 4 colors are aesthetically better). The code is derived from an example in “Teach Yourself Scheme in Fixnum Days” by Dorai Sitaram.

#!r6rs
(import (vicare)
  (vicare language-extensions amb)
  (only (vicare language-extensions syntaxes)
        define-values))

We represent the map with a graph: one node for each nation; nations that face each other are connected by a link. We select the adjacency list representation. We want to make sure that we have correctly defined the graph: two nodes connected by a link must be present in the adjacency list of each other. A better graph definition syntax would have integrated this check.

(define-record-type node
  (fields (immutable name)
          ;;List of NODE  records representing the adjacency
          ;;list of this node.
          (mutable neighbors)
          ;;Symbol representing this node's color.
          (mutable color))
  (protocol (lambda (maker)
              (lambda (name)
                (maker name '() #f)))))

(define-syntax define-nodes
  (syntax-rules ()
    ((_ ?nodes-var (?node (?neighbor ...)) ...)
     (begin
       (define ?node (make-node (quote ?node)))
       ...
       (module ()
         (node-neighbors-set! ?node (list ?neighbor ...))
         ...)
       (define ?nodes-var
         (list ?node ...))
       (module ()
         (assert-graph-consistency ?nodes-var))))
    ))

(define (assert-graph-consistency nodes)
  ;;Verify that every node is  present in the adjacency list
  ;;of all its neighbors.
  ;;
  (define who 'assert-graph-consistency)
  (for-each
      (lambda (node)
        (for-each
            (lambda (neighbor)
              (unless (memq node (node-neighbors neighbor))
                (assertion-violation who
                  "incorrect node links"
                  (node-name node)
                  (node-name neighbor))))
          (node-neighbors node)))
    nodes))

We are interested in nations that face each other, even when there is a sea between them; for example: it is aesthetically more pleasant if France and the United Kingdom are painted in different colors.

(define-nodes europe-facing-nations
  (portugal        (spain))
  (spain           (portugal andorra france))
  (andorra         (spain france))
  (france          (spain andorra monaco italy
                    switzerland germany luxembourg
                    belgium united-kingdom))
  (united-kingdom  (france belgium netherlands denmark
                    norway iceland ireland))
  (ireland         (united-kingdom iceland))
  (monaco          (france))
  (italy           (france greece albania montenegro
                    croatia slovenia austria switzerland
                    san-marino))
  (san-marino      (italy))
  (switzerland     (france italy austria germany
                    liechtenstein))
  (liechtenstein   (switzerland austria))
  (germany         (france switzerland austria czech-republic
                    poland sweden denmark netherlands
                    belgium luxembourg))
  (belgium         (france luxembourg germany netherlands
                    united-kingdom))
  (netherlands     (belgium germany united-kingdom))
  (luxembourg      (france germany belgium))
  (austria         (italy slovenia hungary slovakia
                    czech-republic germany switzerland
                    liechtenstein))
  (slovenia        (italy croatia hungary austria))
  (croatia         (italy montenegro bosnia serbia hungary
                    slovenia))
  (bosnia          (croatia montenegro serbia))
  (montenegro      (croatia italy albania serbia bosnia))
  (albania         (italy greece macedonia serbia
                    montenegro))
  (greece          (italy cyprus bulgaria macedonia albania))
  (cyprus          (greece))
  (macedonia       (albania greece bulgaria serbia))
  (bulgaria        (macedonia greece romania serbia))
  (serbia          (montenegro albania macedonia bulgaria
                    romania hungary croatia bosnia))
  (romania         (serbia bulgaria hungary))
  (hungary         (slovenia croatia serbia romania slovakia
                    austria))
  (slovakia        (austria hungary poland czech-republic))
  (czech-republic  (germany austria slovakia poland))
  (poland          (germany czech-republic slovakia sweden))
  (denmark         (united-kingdom germany sweden norway))
  (sweden          (norway denmark germany poland finland))
  (norway          (united-kingdom denmark sweden finland
                    iceland))
  (finland         (sweden norway))
  (iceland         (ireland united-kingdom norway)))

The only use of amb is in the function that selects a color for a nation. We use amb-permute, rather than the plain amb, to try assigning a different first color to the nations (statistically speaking).

(define (choose-color)
  ;;Every time we call this function: we start a new choice.
  ;;
  (amb-permute 'red 'yellow 'blue 'green))

We validate a possible solution with amb-assert, checking that a node/nation has color different from the one of its neighbors:

(define (validate-all-nodes-color all-nodes)
  (for-all validate-single-node-color all-nodes))

To build a “better” starting point, we also want to test the color of a single node against the colors of its neighbors while we are building the initial choice. When calling this function: the neighbors may not have a color yet: their color field can be set to #f.

(define (validate-single-node-color node)
  (amb-assert (not (memq (node-color node)
                         (map node-color
                           (node-neighbors node))))))

The actual coloring function that selects a color for each nation and validates the solution until all the constraints are satisfied:

(define (color-nations nations)
  (with-ambiguous-choices
   ;;Build an initial choice.
   (for-each
       (lambda (nation)
         (node-color-set! nation (choose-color))
         (validate-single-node-color nation))
     nations)
   ;;Validate the choice and backtrack if needed.
   (validate-all-nodes-color nations)))

(define (print-colors nations)
  (for-each
      (lambda (nation)
        (print "~a: ~a\n"
               (node-name nation)
               (node-color nation))
        (for-each
            (lambda (neighbor)
              (print "\t~a: ~a\n"
                     (node-name neighbor)
                     (node-color neighbor)))
          (node-neighbors nation)))
    europe-facing-nations))

(define (print . args)
  (apply fprintf (current-error-port) args))

1.4.2.3 Graph coloring