Re: Graph coloring with Scheme

[Jan Wedekind]

Thanks for the positive feedback.
Here is a slightly modified version using a curried definition.
I am using the algorithm to color live intervals in order to do register 
allocation.

    (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))))

On Mon, 20 Jun 2016, Andy Wingo wrote:

> What a delight!  Thank you for this elegant snippet :)
>
> Andy
>
> On Fri 14 Nov 2014 19:16, Jan Wedekind <address@hidden> writes:
>
> > Hi,
> > Here is an implementation [1] of Chaitin's graph coloring algorithm
> > using GNU Guile and Graphviz. Any feedback and suggestions are
> > welcome. Let me know if you can make the implementation more concise
> > ;)
> >
> > Regards Jan
> >
> > (use-modules (srfi srfi-1)
> >              (srfi srfi-26))
> > (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? edge node) (or (eq? (car edge) node) (eq? (cdr edge) node)))
> > (define (adjacent graph node) (nodes (filter (cut has-node? <> node) graph)))
> > (define (remove-node graph node) (filter (lambda (edge) (not (has-node? edge 
> > 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 (order graph nodes)
> >   (if (null? nodes) '()
> >     (let [(target (argmin (lambda (node) (length (adjacent graph node))) 
> > nodes))]
> >       (cons target (order (remove-node graph target) (delete target nodes))))))
> > (define (assign-colors graph nodes colors)
> >   (if (null? nodes) '()
> >     (let* [(target    (car 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 '((b . a) (a . c) (d . c)))] (graphviz graph (coloring graph '(red 
> > green blue))))
> >
> > [1] http://wedesoft.de/graph-coloring.html