Graph coloring with Scheme

Graph coloring with Scheme

[Jan Wedekind]

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

Re: Graph coloring with Scheme

[Jan Wedekind]

Forgot to use the ordering actually. It needs to be:

(define (coloring graph nodes) (assign-colors graph (nodes graph) (order graph (nodes graph))))

Or one can do the ordering directly within the "assign-colors" function:

(define (assign-colors graph nodes colors)
   (if (null? nodes) '()
     (let* [(target    (argmin (lambda (node) (length (adjacent graph node))) 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))

On Fri, 14 Nov 2014, Jan Wedekind wrote:

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

Re: Graph coloring with Scheme

[Andy Wingo]

What a delight!  Thank you for this elegant snippet :)

Andy

On Fri 14 Nov 2014 19:16, Jan Wedekind <jan@wedesoft.de> 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

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 <jan@wedesoft.de> 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
>
>