[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Graph coloring with Scheme
From: |
Jan Wedekind |
Subject: |
Re: Graph coloring with Scheme |
Date: |
Mon, 20 Jun 2016 21:30:57 +0100 (BST) |
User-agent: |
Alpine 2.11 (DEB 23 2013-08-11) |
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