dev/graph-algorithms.lisp

   1 (in-package #:metabang.graph)
   2
   3 ;;;
   4
   5 (defstruct (vertex-datum (:conc-name node-) (:type list))
   6   (color nil)
   7   (depth most-positive-fixnum)
   8   (parent nil))
   9
  10
  11 (defmethod initialize-vertex-data ((graph basic-graph))
  12   (let ((vertex-data (make-container 'simple-associative-container)))
  13     (iterate-vertexes graph (lambda (v)
  14                               (setf (item-at vertex-data v)
  15                                     (make-vertex-datum :color :white))))
  16     (values vertex-data)))
  17
  18 ;;; breadth-first-search by GWK
  19
  20 (defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
  21   (breadth-first-visitor graph (find-vertex graph source) fn))
  22
  23
  24 (defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
  25   ;; initialize
  26   (let ((vertex-data (initialize-vertex-data graph))
  27         (queue (make-container 'basic-queue)))
  28
  29     (let ((source-datum (item-at vertex-data source)))
  30       (setf (node-color source-datum) :grey
  31             (node-depth source-datum) 0)
  32       (enqueue queue source)
  33
  34       (loop until (empty-p queue) do
  35             (let* ((current-vertex (first-item queue))
  36                    (current (item-at vertex-data current-vertex)))
  37               ;(format t "~%~A:" current-vertex)
  38               (iterate-children current-vertex
  39                                 (lambda (child-vertex)
  40                                   ;(format t "~A " child-vertex)
  41                                   (let ((child (item-at vertex-data child-vertex)))
  42                                     (when (eq (node-color child) :white)
  43                                       (setf (node-color child) :grey
  44                                             (node-depth child) (1+ (node-depth current))
  45                                             (node-parent child) current-vertex)
  46                                       (enqueue queue child-vertex)))))
  47
  48               (dequeue queue)
  49               (setf (node-color current) :black)
  50               (funcall fn current-vertex)))
  51
  52       vertex-data)))
  53
  54
  55 (defmethod breadth-first-search-graph ((graph basic-graph) (source t))
  56   (breadth-first-search-graph graph (find-vertex graph source)))
  57
  58
  59 (defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
  60   ;; initialize
  61   (let ((vertex-data (initialize-vertex-data graph))
  62         (queue (make-container 'basic-queue)))
  63
  64     (let ((source-datum (item-at vertex-data source)))
  65       (setf (node-color source-datum) :grey
  66             (node-depth source-datum) 0)
  67       (enqueue queue source)
  68
  69       (loop until (empty-p queue) do
  70             (let* ((current-vertex (first-item queue))
  71                    (current (item-at vertex-data current-vertex)))
  72               ;(format t "~%~A:" current-vertex)
  73               (iterate-children current-vertex
  74                                 (lambda (child-vertex)
  75                                   ;(format t "~A " child-vertex)
  76                                   (let ((child (item-at vertex-data child-vertex)))
  77                                     (when (eq (node-color child) :white)
  78                                       (setf (node-color child) :grey
  79                                             (node-depth child) (1+ (node-depth current))
  80                                             (node-parent child) current-vertex)
  81                                       (enqueue queue child-vertex)))))
  82
  83               (dequeue queue)
  84               (setf (node-color current) :black)))
  85
  86       vertex-data)))
  87
  88 ;;; single-source-shortest-paths - gwk
  89
  90 #+NotYet
  91 (defmethod single-source-shortest-paths ((graph basic-graph))
  92   (let ((vertex-data (initialize-vertex-data graph))
  93         (queue (make-container 'priority-queue-on-container 'binary-search-tree)))
  94     (let ((source-datum (item-at vertex-data source)))
  95       (setf (node-depth source-datum) 0))
  96     ))
  97
  98 ;;; connected-components - gwk
  99
 100 (defmethod connected-components ((graph basic-graph))
 101   (let ((union (make-container 'union-find-container)))
 102     (iterate-vertexes
 103      graph
 104      (lambda (v) (insert-item union v)))
 105     (iterate-edges
 106      graph
 107      (lambda (e)
 108        (let ((node-1 (representative-node union (vertex-1 e)))
 109              (node-2 (representative-node union (vertex-2 e))))
 110          (unless (eq (find-set node-1) (find-set node-2))
 111            (graft-nodes node-1 node-2)))))
 112     (iterate-elements union 'find-set)
 113     union))
 114
 115
 116 (defmethod connected-component-count ((graph basic-graph))
 117   ;;?? Gary King 2005-11-28: Super ugh
 118   (size
 119    (remove-duplicates
 120     (collect-elements
 121      (connected-components graph)
 122      :transform #'parent)))
 123
 124   #+Fails
 125   ;;?? Gary King 2005-11-28: fails on big graphs? iterator design
 126   ;;?? Gary King 2005-11-28: ideally we don't want to cons up the list at all
 127   (size
 128    (collect-elements
 129     (make-iterator (connected-components graph) :unique t :transform #'parent))))
 130
 131 (defmethod find-connected-components ((graph basic-graph))
 132   (collect-elements
 133    (make-iterator (connected-components graph) :unique t :transform #'parent)
 134    :transform
 135    (lambda (component)
 136      (subgraph-containing graph (element component)
 137                           :depth most-positive-fixnum))))
 138
 139 #+Alternate
 140 (defmethod find-connected-components ((graph basic-graph))
 141   (let ((result nil)
 142         (found-elements (make-container 'simple-associative-container)))
 143     (iterate-elements
 144      (connected-components graph)
 145      (lambda (component)
 146        (let ((element (element (parent component))))
 147          (unless (item-at found-elements element)
 148            (setf (item-at found-elements element) t)
 149            (push (subgraph-containing graph (element component)
 150                                       most-positive-fixnum)
 151                  result)))))
 152
 153     result))
 154
 155
 156
 157 ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
 158
 159 (defmethod mst-find-set ((vertex basic-vertex))
 160   #+ignore
 161   (unless (previous-node vertex)
 162     (return-from mst-find-set nil))
 163   (unless (eq vertex (previous-node vertex))
 164     (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
 165   (previous-node vertex))
 166
 167
 168 (defmethod mst-make-set ((vertex basic-vertex))
 169   (setf (previous-node vertex) vertex
 170         (rank vertex) 0))
 171
 172
 173 (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
 174   (mst-link (mst-find-set v1) (mst-find-set v2)))
 175
 176
 177 (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
 178   (cond ((> (rank v1) (rank v2))
 179          (setf (previous-node v2) v1))
 180         (t (setf (previous-node v1) v2)
 181            (when (= (rank v1) (rank v2))
 182              (incf (rank v2))))))
 183
 184 ;;; jjm's implementation of mst depends on this
 185 ;;; todo - figure out some what to add and edge we create to a graph rather
 186 ;;; than always using add-edge-between-vertexes interface
 187
 188 (defmethod add-edges-to-graph ((graph basic-graph) (edges list)
 189                                &key (if-duplicate-do :ignore))
 190   (iterate-elements
 191    edges
 192    (lambda (edge)
 193      (let ((v1 (element (source-vertex edge)))
 194            (v2 (element (target-vertex edge))))
 195        (add-edge-between-vertexes
 196         graph v1 v2 :edge-class (type-of edge)
 197         :edge-type (if (directed-edge-p edge)
 198                      :directed
 199                      :undirected)
 200         :value (value edge)
 201         :edge-id (edge-id edge)
 202         :element (element edge)
 203         :tag (tag edge)
 204         :graph graph
 205         :color (color edge)
 206         :if-duplicate-do if-duplicate-do))))
 207   graph)
 208
 209
 210 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
 211   (< (weight e1) (weight e2)))
 212
 213 ;;; minumum spanning tree
 214
 215
 216 (defmethod minimum-spanning-tree ((graph basic-graph)
 217                                   &key
 218                                   (edge-sorter #'edge-lessp-by-weight))
 219   (let ((result nil))
 220     (iterate-vertexes
 221      graph
 222      (lambda (v)
 223        (mst-make-set v)))
 224
 225     (loop for edge in (sort (edges graph) edge-sorter) do
 226           (let ((v1 (source-vertex edge))
 227                  (v2 (target-vertex edge)))
 228
 229             (unless (eq (mst-find-set v1)
 230                         (mst-find-set v2))
 231               (push edge result)
 232               (mst-tree-union v1 v2)))
 233           finally
 234           (return
 235            (cond ((= (length result) (- (length (vertexes graph)) 1))
 236                   (values t result))
 237                  (t (values nil result)))))))
 238
 239
 240 #+ignore ;;; shoot
 241 (defmethod minimum-spanning-tree ((vertex-list list)
 242                                   &key
 243                                   (edge-sorter #'edge-lessp-by-weight))
 244   (let ((result nil)
 245          (v-edges (remove-duplicates
 246                    (flatten (mapcar #'edges vertex-list)) :test #'eq)))
 247
 248     (iterate-container
 249      vertex-list
 250      (lambda (v)
 251        (mst-make-set v)))
 252
 253     (loop for edge in (sort v-edges edge-sorter) do
 254           (let ((v1 (source-vertex edge))
 255                 (v2 (target-vertex edge))
 256                 (v1-set (mst-find-set v1))
 257                 (v2-set (mst-find-set v2)))
 258
 259             (when (or (not v1-set)
 260                            (not v2-set))
 261               (return-from minimum-spanning-tree nil))
 262
 263
 264             (unless (eq (mst-find-set v1)
 265                         (mst-find-set v2))
 266               (push edge result)
 267               (mst-tree-union v1 v2)))
 268           finally
 269           (return
 270            (cond ((= (length result) (- (length vertex-list) 1))
 271                   (values t result))
 272                  (t (values nil result)))))))
 273
 274 ;;; uses mst to determine if the graph is connected
 275
 276 (defmethod connected-graph-p ((graph basic-graph) &key
 277                               (edge-sorter 'edge-lessp-by-weight))
 278   (minimum-spanning-tree graph :edge-sorter edge-sorter))
 279
 280
 281
 282 #+test
 283 (let ((g (make-container 'graph-container)))
 284   (add-edge-between-vertexes g :v :y :edge-type :directed)
 285   (add-edge-between-vertexes g :u :x :edge-type :directed)
 286   (add-edge-between-vertexes g :x :v :edge-type :directed)
 287   (add-edge-between-vertexes g :u :v :edge-type :directed)
 288   (add-edge-between-vertexes g :y :x :edge-type :directed)
 289   (add-edge-between-vertexes g :w :y :edge-type :directed)
 290   (add-edge-between-vertexes g :w :z :edge-type :directed)
 291   (add-edge-between-vertexes g :z :z :edge-type :directed
 292                              :if-duplicate-do :force)
 293   (minimum-spanning-tree g))
 294
 295 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
 296 ;;; a tree (still faster even if it does).  Will decide later if which to use
 297 ;;; ignoring for now -jjm
 298
 299 #+not-yet
 300 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
 301   (let ((a nil)
 302         (union (make-container 'union-find-container))
 303         (edges (sort (edges graph) #'< :key weight)))
 304     (iterate-vertexes
 305      graph (lambda (v) (insert-item union v)))
 306     (dolist (edge edges)
 307       (let ((node-1 (representative-node union (vertex-1 edge)))
 308             (node-2 (representative-node union (vertex-2 edge))))
 309         (unless (eq (find-set node-1) (find-set node-2))
 310           (graft-nodes node-1 node-2)
 311           (push edge a))))
 312
 313     (values a)))
 314
 315
 316 #+test
 317 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
 318       (fluid-bind (((random-seed *random-generator*) 1))
 319         (bind ((g (generate-undirected-graph-via-vertex-probabilities
 320                    *random-generator* (make-instance 'graph-container :default-edge-type :directed)
 321                    100
 322                    #(0.8 0.2)
 323                    #2A((0.2 0.1) (nil 0.2))
 324                    (lambda (kind count)
 325                      (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 326                   ))
 327           (timeit (:report :values)
 328                   (loop for n from 1 to 100 do
 329                         (funcall f g (lambda (a b)
 330                                        (declare (ignore a b))
 331                                        0)))))))
 332
 333 ;;; end minimum spanning tree
 334
 335
 336 ;;; depth-first-search - clrs2
 337 ;;; todo - figure out how to name this depth-first-search, which is already
 338 ;;; defined in search.lisp
 339
 340 ;;; should probably make this special
 341
 342 (defparameter *depth-first-search-timer* -1)
 343
 344 ;;; undirected edges are less than edges that are directed
 345
 346 #+ignore ;;; incorrect, methinks - jjm
 347 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 348   (cond ((or (every #'directed-edge-p (list e1 e2))
 349              (every #'undirected-edge-p (list e1 e2)))
 350          t)
 351         ((and (undirected-edge-p e1) (directed-edge-p e2))
 352          t)
 353         (t nil)))
 354
 355 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 356   (and (undirected-edge-p e1) (directed-edge-p e2)))
 357
 358
 359 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
 360   (cond ((and (directed-edge-p edge)
 361               (eq vertex (source-vertex edge)))
 362          t)
 363         ((and (undirected-edge-p edge)
 364               (or (eq vertex (source-vertex edge))
 365                   (eq vertex (target-vertex edge))))
 366          t)
 367         (t nil)))
 368
 369 ;;; depth-first-search
 370
 371 (defmethod dfs ((graph basic-graph) (root t) fn &key
 372                 (out-edge-sorter #'edge-lessp-by-direction))
 373   (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
 374
 375
 376 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
 377                 (out-edge-sorter #'edge-lessp-by-direction))
 378   (setf *depth-first-search-timer* -1)
 379
 380   (iterate-vertexes
 381    graph
 382    (lambda (v)
 383      (setf (color v) :white
 384            (previous-node v) nil
 385            (discovery-time v) -1
 386            (finish-time v) -1)))
 387
 388   (iterate-edges
 389    graph
 390    (lambda (e)
 391      (setf (color e) nil)))
 392
 393   (loop for v in (cons root (remove root (vertexes graph) :test #'eql))
 394         when (eql (color v) :white)
 395           do (dfs-visit graph v fn out-edge-sorter))
 396
 397   (values
 398    (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
 399    graph))
 400
 401 (defgeneric rooted-dfs (graph root fn &key out-edge-sorter)
 402   (:documentation "A variant of DFS that does not visit nodes that are
 403 unreachable from the ROOT.")
 404   (:method ((graph basic-graph) (root t) fn &key
 405             (out-edge-sorter #'edge-lessp-by-direction))
 406      (rooted-dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
 407   (:method ((graph basic-graph) (root basic-vertex) fn &key
 408                 (out-edge-sorter #'edge-lessp-by-direction))
 409        (setf *depth-first-search-timer* -1)
 410
 411   (iterate-vertexes
 412    graph
 413    (lambda (v)
 414      (setf (color v) :white
 415            (previous-node v) nil
 416            (discovery-time v) -1
 417            (finish-time v) -1)))
 418
 419   (iterate-edges
 420    graph
 421    (lambda (e)
 422      (setf (color e) nil)))
 423
 424   (dfs-visit graph root fn out-edge-sorter)
 425
 426   (values
 427    (sort (remove-if #'(lambda (v) (eq (color v) :white))
 428                     (vertexes graph))
 429          #'< :key #'finish-time)
 430    graph)))
 431
 432
 433 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
 434                                      fn sorter)
 435
 436
 437   (incf *depth-first-search-timer*)
 438   ;; the following should be removed later for efficiency [2011/03/10:rpg]
 439   (unless (eq (color u) :white)
 440     (error "precondition for DFS-VISIT violated."))
 441   (setf (color u) :gray
 442         (discovery-time u) *depth-first-search-timer*)
 443   ;; moved the funcall up here, fixing a boundary condition where the
 444   ;; function was never called on root nodes. [2011/03/10:rpg]
 445   (funcall fn u)
 446
 447   (loop for edge in (sort (collect-elements
 448                            (edges u)
 449                            :filter (lambda (e)
 450                                      (out-edge-for-vertex-p e u))) sorter)
 451         as v = (other-vertex edge u)
 452         unless (color edge)
 453           do (setf (color edge) (color v))
 454         when (eql (color v) :white)
 455           do
 456               (setf (previous-node v) u)
 457               (dfs-visit graph v fn sorter))
 458
 459   (incf *depth-first-search-timer*)
 460
 461   (setf (color u) :black
 462         (finish-time u) *depth-first-search-timer*))
 463
 464 ;;; from clrs2
 465
 466 #+test
 467 (let ((g (make-container 'graph-container)))
 468   (add-edge-between-vertexes g :v :y :edge-type :directed)
 469   (add-edge-between-vertexes g :u :x :edge-type :directed)
 470   (add-edge-between-vertexes g :x :v :edge-type :directed)
 471   (add-edge-between-vertexes g :u :v :edge-type :directed)
 472   (add-edge-between-vertexes g :y :x :edge-type :directed)
 473   (add-edge-between-vertexes g :w :y :edge-type :directed)
 474   (add-edge-between-vertexes g :w :z :edge-type :directed)
 475   (add-edge-between-vertexes g :z :z :edge-type :directed
 476                              :if-duplicate-do :force)
 477   (assert (equal '(:X :Y :V :U :Z :W)
 478                  (mapcar #'element (dfs g :u #'identity)))))
 479
 480
 481 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
 482   (eql (color edge) :white))
 483
 484
 485 (defmethod dfs-back-edge-p ((edge graph-container-edge))
 486   (eql (color edge) :gray))
 487
 488 ;;; not correct - has to look at combination of discovery-time and finish-time
 489
 490 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
 491   (warn "implementation is not correct.")
 492   (unless (and (dfs-tree-edge-p edge)
 493                (dfs-back-edge-p edge))
 494     (< (discovery-time (source-vertex edge))
 495        (discovery-time (target-vertex edge)))))
 496
 497 ;;; not correct - has to look at combination of discovery-time and finish-time
 498
 499 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
 500   (warn "implementation is not correct.")
 501   (unless (and (dfs-tree-edge-p edge)
 502                (dfs-back-edge-p edge))
 503     (> (discovery-time (source-vertex edge))
 504        (discovery-time (target-vertex edge)))))
 505
 506
 507 (defmethod dfs-edge-type ((edge graph-container-edge))
 508   (cond ((dfs-tree-edge-p edge)
 509          :tree)
 510         ((dfs-back-edge-p edge)
 511          :back)
 512         ((dfs-forward-edge-p edge)
 513          :forward)
 514         ((dfs-cross-edge-p edge)
 515          :cross)
 516         (t nil)))
 517
 518 ;;; end dfs
 519
 520 ;;; mapping functions
 521
 522 ;;; over vertexes
 523
 524 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
 525   (let* ((vertex-count (size graph))
 526          (symbols (make-list k :initial-element vertex-count))
 527          (vertexes (vertexes graph)))
 528     (iterate-over-indexes
 529      symbols
 530      (lambda (vertex-indexes)
 531        (when (apply #'< vertex-indexes)
 532          (funcall fn (mapcar (lambda (vertex-index)
 533                                (nth-element vertexes vertex-index))
 534                              vertex-indexes)))))))
 535
 536
 537 #+test
 538 (let ((result nil)
 539        (g (make-container 'graph-container)))
 540   (add-edge-between-vertexes g :u :v :edge-type :directed)
 541   (add-edge-between-vertexes g :u :x :edge-type :directed)
 542   (add-edge-between-vertexes g :x :v :edge-type :directed)
 543   (add-edge-between-vertexes g :v :y :edge-type :directed)
 544   (add-edge-between-vertexes g :y :x :edge-type :directed)
 545   (add-edge-between-vertexes g :w :y :edge-type :directed)
 546   (add-edge-between-vertexes g :w :z :edge-type :directed)
 547
 548   (map-over-all-combinations-of-k-vertexes
 549    g
 550    4
 551    (lambda (vertex-list)
 552      (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
 553        (when (mst-kruskal graph-from-vertexes #'identity-sorter)
 554          (push graph-from-vertexes result)))))
 555   result)
 556
 557 ;;; over edges
 558 ;;; todo: merge these two defs
 559
 560 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
 561   (let* ((edge-count (edge-count graph))
 562          (symbols (make-list k :initial-element edge-count))
 563          (edges (edges graph)))
 564     (print symbols)
 565     (iterate-over-indexes
 566      symbols
 567      (lambda (edge-indexes)
 568        (when (apply #'< edge-indexes)
 569          (funcall fn (mapcar (lambda (edge-index)
 570                                (nth-element edges edge-index))
 571                              edge-indexes)))))))
 572
 573
 574 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
 575   (let* ((edge-count (edge-count vertex))
 576          (symbols (make-list k :initial-element edge-count))
 577          (edges (edges vertex)))
 578     ;(print symbols)
 579     (iterate-over-indexes
 580      symbols
 581      (lambda (edge-indexes)
 582        (when (apply #'< edge-indexes)
 583          (funcall fn (mapcar (lambda (edge-index)
 584                                (nth-element edges edge-index))
 585                              edge-indexes)))))))
 586
 587 #+test
 588 (map-over-all-combinations-of-k-edges
 589  (generate-undirected-graph-via-verex-probabilities
 590   *random-generator* 'graph-container
 591   10
 592   #(0.8 0.2)
 593   #2A((0.2 0.1) (nil 0.2))
 594   (lambda (kind count)
 595     (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 596  2
 597  (lambda (es)
 598    (format t "~%")
 599    (mapc (lambda (e)
 600            (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
 601          es)))
 602
 603
 604
 605
 606
 607 ;;; ***************************************************************************
 608 ;;; *                              End of File                                *
 609 ;;; ***************************************************************************