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: Tue, 18 Nov 2014 12:27:25 +0000 (GMT) Message-ID: References: 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 1416313680 4021 80.91.229.3 (18 Nov 2014 12:28:00 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 18 Nov 2014 12:28:00 +0000 (UTC) To: General Guile related discussions Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Tue Nov 18 13:27:54 2014 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 1Xqhsw-0007fb-1w for guile-user@m.gmane.org; Tue, 18 Nov 2014 13:27:54 +0100 Original-Received: from localhost ([::1]:52778 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Xqhsu-0003Of-LB for guile-user@m.gmane.org; Tue, 18 Nov 2014 07:27:52 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:34101) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Xqhsd-0003OJ-TN for guile-user@gnu.org; Tue, 18 Nov 2014 07:27:42 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XqhsW-00088L-IU for guile-user@gnu.org; Tue, 18 Nov 2014 07:27:35 -0500 Original-Received: from basicbox4.server-home.net ([195.137.212.26]:50256) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XqhsW-00085h-Cp for guile-user@gnu.org; Tue, 18 Nov 2014 07:27:28 -0500 Original-Received: from wedemob.local (salt-ext.roke.co.uk [109.207.29.2]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by basicbox4.server-home.net (Postfix) with ESMTPSA id 15DD915307DF for ; Tue, 18 Nov 2014 13:27:26 +0100 (CET) X-X-Sender: jan@wedemob.home In-Reply-To: User-Agent: Alpine 2.02 (DEB 1266 2009-07-14) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 195.137.212.26 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.14 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-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:11641 Archived-At: 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 > >