Graph coloring using Chaitin's algorithm

graph-coloring.scm

(use-modules (srfi srfi-1) (srfi srfi-26) (ice-9 curried-definitions))
(define (dot graph colors)
  (apply string-append
         (append (list "graph g {")
                 (map (lambda (color) (format #f " ~a [style=filled, fillcolor=~a];" (car color) (cdr color))) colors)
                 (map (lambda (edge) (format #f " ~a -- ~a;" (car edge) (cdr edge))) graph)
                 (list " }"))))
(define (graphviz graph colors) (system (format #f "echo '~a' | dot -Tpng | display -" (dot graph colors))))
(define (nodes graph) (delete-duplicates (append (map car graph) (map cdr graph))))
(define ((has-node? node) edge) (or (eq? (car edge) node) (eq? (cdr edge) node)))
(define (adjacent graph node) (nodes (filter (has-node? node) graph)))
(define (remove-node graph node) (filter (compose not (has-node? node)) graph))
(define (argmin fun lst)
  (let* [(vals   (map fun lst))
         (minval (apply min vals))]
    (list-ref lst (- (length lst) (length (member minval vals))))))
(define (assign-colors graph nodes colors)
  (if (null? nodes) '()
    (let* [(target    (argmin (compose length (cut adjacent graph <>)) nodes))
           (coloring  (assign-colors (remove-node graph target) (delete target nodes) colors))
           (blocked   (map (cut assq-ref coloring <>) (adjacent graph target)))
           (available (lset-difference eq? colors blocked))]
      (cons (cons target (car available)) coloring))))
(define (coloring graph colors) (assign-colors graph (nodes graph) colors))
(let [(graph '((run . intr)
               (intr . runbl)
               (runbl . run)
               (run . kernel)
               (kernel . zombie)
               (kernel . sleep)
               (kernel . runmem)
               (sleep . swap)
               (swap . runswap)
               (runswap . new)
               (runswap . runmem)
               (new . runmem)
               (sleep . runmem)))]
  (graphviz graph (coloring graph '(red green blue yellow))))