From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Jan Wedekind Newsgroups: gmane.lisp.guile.user Subject: Re: Graph coloring with Scheme Date: Mon, 20 Jun 2016 21:30:57 +0100 (BST) Message-ID: References: <877fdkhuqi.fsf@pobox.com> Reply-To: Jan Wedekind NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: TEXT/PLAIN; charset=US-ASCII; format=flowed X-Trace: ger.gmane.org 1466456031 7163 80.91.229.3 (20 Jun 2016 20:53:51 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 20 Jun 2016 20:53:51 +0000 (UTC) Cc: General Guile related discussions To: Andy Wingo Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Mon Jun 20 22:53:36 2016 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1bF6CK-0007hb-DS for guile-user@m.gmane.org; Mon, 20 Jun 2016 22:53:32 +0200 Original-Received: from localhost ([::1]:46436 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bF6CJ-0003WP-3t for guile-user@m.gmane.org; Mon, 20 Jun 2016 16:53:31 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:48727) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bF5qd-0004T4-0a for guile-user@gnu.org; Mon, 20 Jun 2016 16:31:08 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bF5qY-0007Sf-Od for guile-user@gnu.org; Mon, 20 Jun 2016 16:31:05 -0400 Original-Received: from basicbox4.server-home.net ([195.137.212.26]:39678) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bF5qY-0007Rj-E9 for guile-user@gnu.org; Mon, 20 Jun 2016 16:31:02 -0400 Original-Received: from wedemob.default (unknown [95.150.201.158]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by basicbox4.server-home.net (Postfix) with ESMTPSA id 268C21530668; Mon, 20 Jun 2016 22:30:58 +0200 (CEST) X-X-Sender: jan@wedemob In-Reply-To: <877fdkhuqi.fsf@pobox.com> User-Agent: Alpine 2.11 (DEB 23 2013-08-11) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 195.137.212.26 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Original-Sender: "guile-user" Xref: news.gmane.org gmane.lisp.guile.user:12668 Archived-At: 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 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 > >