From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.user Subject: Re: Graph coloring with Scheme Date: Mon, 20 Jun 2016 15:09:57 +0200 Message-ID: <877fdkhuqi.fsf@pobox.com> References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: ger.gmane.org 1466428259 8009 80.91.229.3 (20 Jun 2016 13:10:59 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 20 Jun 2016 13:10:59 +0000 (UTC) Cc: General Guile related discussions To: Jan Wedekind Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Mon Jun 20 15:10:47 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 1bEyyM-0001QL-GN for guile-user@m.gmane.org; Mon, 20 Jun 2016 15:10:38 +0200 Original-Received: from localhost ([::1]:43564 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bEyyL-0005QR-Ns for guile-user@m.gmane.org; Mon, 20 Jun 2016 09:10:37 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:59349) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bEyxx-0005Nt-96 for guile-user@gnu.org; Mon, 20 Jun 2016 09:10:17 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bEyxq-0002l5-AJ for guile-user@gnu.org; Mon, 20 Jun 2016 09:10:12 -0400 Original-Received: from pb-sasl1.pobox.com ([64.147.108.66]:56980 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bEyxq-0002kc-2R for guile-user@gnu.org; Mon, 20 Jun 2016 09:10:06 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by pb-sasl1.pobox.com (Postfix) with ESMTP id 4CA90223DD; Mon, 20 Jun 2016 09:10:05 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; s=sasl; bh=H6GZcxAcjM/ztMen7U+F2pq1yzE=; b=FVfRPf FBPhl+zlBNAJgsVkMgEOU8Hc4k1pD9LSHAsPCk4lgloM60/Jtqku5KF0ScoUCcoB 0PN71W2pA1KNAhOuZz1iCoNGAeN2+IObvGutJ8qq/O2RTRmGyJHQJ6Qizf+cl6qn KcQpUfxhPQcGxSS1D43A9Zh1Z6N3kxQnnB33E= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; q=dns; s=sasl; b=br2lKORILhjNUxeLO+6TOwnctEDxwXcD uYleMRpsT22aWjg5L2Q4qEpCToYdH0bwdfmpbsIy4DmFLLWHyDl4cSA2tqB8uRjL lOLG0yege1vQCEsxYZpzKyruWIlVWPZlsRoa393sC2/DmEkx3V//w2Z1pjZRt8T3 K8GYCbyP00c= Original-Received: from pb-sasl1.nyi.icgroup.com (unknown [127.0.0.1]) by pb-sasl1.pobox.com (Postfix) with ESMTP id 43E09223DC; Mon, 20 Jun 2016 09:10:05 -0400 (EDT) Original-Received: from clucks (unknown [88.160.190.192]) (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by pb-sasl1.pobox.com (Postfix) with ESMTPSA id 63FA7223DA; Mon, 20 Jun 2016 09:10:04 -0400 (EDT) In-Reply-To: (Jan Wedekind's message of "Fri, 14 Nov 2014 18:16:02 +0000 (GMT)") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) X-Pobox-Relay-ID: 4DC9DE44-36E8-11E6-851E-C1836462E9F6-02397024!pb-sasl1.pobox.com X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 64.147.108.66 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:12662 Archived-At: 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