Skip to content
Browse files

maximal cliques with Bron-Kerbosch

  • Loading branch information...
1 parent 43fd0a1 commit ffeb5d78c6dd0758921cf83996c7fea0b8dfe7d8 @abarbu abarbu committed Jan 31, 2013
Showing with 36 additions and 0 deletions.
  1. +21 −0 examples/graph-overview.scm
  2. +15 −0 graph.scm
View
21 examples/graph-overview.scm
@@ -153,6 +153,7 @@
(pp (let ((graph
(digraph->graph
(alist->digraph
+ ;; http://en.wikipedia.org/wiki/File:6n-graf.svg
'((1 2) (1 5)
(5 4) (5 2) (2 3)
(3 4) (4 6))))))
@@ -169,3 +170,23 @@
(f g)
(g f)
(h g) (h d))))))
+
+(define (graph-clique-example)
+ (list
+ (let ((graph
+ (digraph->graph
+ (alist->digraph
+ ;; http://en.wikipedia.org/wiki/File:6n-graf.svg
+ '((1 2) (1 5)
+ (5 4) (5 2) (2 3)
+ (3 4) (4 6))))))
+ ;; ((6 4) (4 3) (3 2) (4 5) (2 5 1))
+ (map (lambda (l) (map vertex-label l)) (graph-maximal-cliques graph)))
+ (let ((graph
+ (digraph->graph
+ (alist->digraph
+ '((1 2) (1 5)
+ (5 4) (5 2) (2 3)
+ (3 4) (4 6) (5 3) (2 4))))))
+ ;; ((6 4) (2 4 3 5) (2 5 1))
+ (map (lambda (l) (map vertex-label l)) (graph-maximal-cliques graph)))))
View
15 graph.scm
@@ -66,6 +66,7 @@
(define (vertex-incoming-edges? v) (not (null? (vertex-in-edges v))))
(define (copy-vertex v) (make-vertex (vertex-label v) (vertex-edges v)))
(define (copy-edge v) (make-edge (edge-label v) (edge-out v) (edge-in v)))
+(define (vertex-neighbours v) (map edge-in (vertex-out-edges v)))
(define (alist->digraph alist)
(let*
@@ -401,4 +402,18 @@
vertices (graph-vertices graph))
(make-graph vertices edges)))
+(define (graph-maximal-cliques graph)
+ ;; Bron-Kerbosch, without pivoting or vertex ordering
+ (let ((max-cliques '()))
+ (let loop ((r '()) (p (graph-vertices graph)) (x '()))
+ (if (and (null? p) (null? x))
+ (push! r max-cliques)
+ (for-each (lambda (v)
+ (loop (cons v r)
+ (intersectionq (vertex-neighbours v) p)
+ (intersectionq (vertex-neighbours v) x))
+ (push! v x)
+ (set! p (removeq v p)))
+ p)))
+ max-cliques))
)

0 comments on commit ffeb5d7

Please sign in to comment.
Something went wrong with that request. Please try again.