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 with vl = (remove root (vertexes graph) :test #'eql)
 394         for v in (push root vl) do
 395         (when (eql (color v) :white)
 396           (dfs-visit graph v fn out-edge-sorter)))
 397
 398   (values
 399    (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
 400    graph))
 401
 402
 403 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
 404                                      fn sorter)
 405
 406
 407   (incf *depth-first-search-timer*)
 408   (setf (color u) :gray
 409         (discovery-time u) *depth-first-search-timer*)
 410
 411
 412   (loop for edge in (sort (collect-elements
 413                            (edges u)
 414                            :filter (lambda (e)
 415                                      (out-edge-for-vertex-p e u))) sorter) do
 416         (let ((v (other-vertex edge u)))
 417
 418           (unless (color edge)
 419             (setf (color edge) (color v)))
 420
 421           (when (eql (color v) :white)
 422               (setf (previous-node v) u)
 423               (funcall fn v)
 424               (dfs-visit graph v fn sorter))))
 425
 426   (incf *depth-first-search-timer*)
 427
 428   (setf (color u) :black
 429         (finish-time u) *depth-first-search-timer*))
 430
 431 ;;; from clrs2
 432
 433 #+test
 434 (let ((g (make-container 'graph-container)))
 435   (add-edge-between-vertexes g :v :y :edge-type :directed)
 436   (add-edge-between-vertexes g :u :x :edge-type :directed)
 437   (add-edge-between-vertexes g :x :v :edge-type :directed)
 438   (add-edge-between-vertexes g :u :v :edge-type :directed)
 439   (add-edge-between-vertexes g :y :x :edge-type :directed)
 440   (add-edge-between-vertexes g :w :y :edge-type :directed)
 441   (add-edge-between-vertexes g :w :z :edge-type :directed)
 442   (add-edge-between-vertexes g :z :z :edge-type :directed
 443                              :if-duplicate-do :force)
 444   (assert (equal '(:X :Y :V :U :Z :W)
 445                  (mapcar #'element (dfs g :u #'identity)))))
 446
 447
 448 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
 449   (eql (color edge) :white))
 450
 451
 452 (defmethod dfs-back-edge-p ((edge graph-container-edge))
 453   (eql (color edge) :gray))
 454
 455 ;;; not correct - has to look at combination of discovery-time and finish-time
 456
 457 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
 458   (warn "implementation is not correct.")
 459   (unless (and (dfs-tree-edge-p edge)
 460                (dfs-back-edge-p edge))
 461     (< (discovery-time (source-vertex edge))
 462        (discovery-time (target-vertex edge)))))
 463
 464 ;;; not correct - has to look at combination of discovery-time and finish-time
 465
 466 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
 467   (warn "implementation is not correct.")
 468   (unless (and (dfs-tree-edge-p edge)
 469                (dfs-back-edge-p edge))
 470     (> (discovery-time (source-vertex edge))
 471        (discovery-time (target-vertex edge)))))
 472
 473
 474 (defmethod dfs-edge-type ((edge graph-container-edge))
 475   (cond ((dfs-tree-edge-p edge)
 476          :tree)
 477         ((dfs-back-edge-p edge)
 478          :back)
 479         ((dfs-forward-edge-p edge)
 480          :forward)
 481         ((dfs-cross-edge-p edge)
 482          :cross)
 483         (t nil)))
 484
 485 ;;; end dfs
 486
 487 ;;; mapping functions
 488
 489 ;;; over vertexes
 490
 491 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
 492   (let* ((vertex-count (size graph))
 493          (symbols (make-list k :initial-element vertex-count))
 494          (vertexes (vertexes graph)))
 495     (iterate-over-indexes
 496      symbols
 497      (lambda (vertex-indexes)
 498        (when (apply #'< vertex-indexes)
 499          (funcall fn (mapcar (lambda (vertex-index)
 500                                (nth-element vertexes vertex-index))
 501                              vertex-indexes)))))))
 502
 503
 504 #+test
 505 (let ((result nil)
 506        (g (make-container 'graph-container)))
 507   (add-edge-between-vertexes g :u :v :edge-type :directed)
 508   (add-edge-between-vertexes g :u :x :edge-type :directed)
 509   (add-edge-between-vertexes g :x :v :edge-type :directed)
 510   (add-edge-between-vertexes g :v :y :edge-type :directed)
 511   (add-edge-between-vertexes g :y :x :edge-type :directed)
 512   (add-edge-between-vertexes g :w :y :edge-type :directed)
 513   (add-edge-between-vertexes g :w :z :edge-type :directed)
 514
 515   (map-over-all-combinations-of-k-vertexes
 516    g
 517    4
 518    (lambda (vertex-list)
 519      (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
 520        (when (mst-kruskal graph-from-vertexes #'identity-sorter)
 521          (push graph-from-vertexes result)))))
 522   result)
 523
 524 ;;; over edges
 525 ;;; todo: merge these two defs
 526
 527 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
 528   (let* ((edge-count (edge-count graph))
 529          (symbols (make-list k :initial-element edge-count))
 530          (edges (edges graph)))
 531     (print symbols)
 532     (iterate-over-indexes
 533      symbols
 534      (lambda (edge-indexes)
 535        (when (apply #'< edge-indexes)
 536          (funcall fn (mapcar (lambda (edge-index)
 537                                (nth-element edges edge-index))
 538                              edge-indexes)))))))
 539
 540
 541 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
 542   (let* ((edge-count (edge-count vertex))
 543          (symbols (make-list k :initial-element edge-count))
 544          (edges (edges vertex)))
 545     ;(print symbols)
 546     (iterate-over-indexes
 547      symbols
 548      (lambda (edge-indexes)
 549        (when (apply #'< edge-indexes)
 550          (funcall fn (mapcar (lambda (edge-index)
 551                                (nth-element edges edge-index))
 552                              edge-indexes)))))))
 553
 554 #+test
 555 (map-over-all-combinations-of-k-edges
 556  (generate-undirected-graph-via-verex-probabilities
 557   *random-generator* 'graph-container
 558   10
 559   #(0.8 0.2)
 560   #2A((0.2 0.1) (nil 0.2))
 561   (lambda (kind count)
 562     (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 563  2
 564  (lambda (es)
 565    (format t "~%")
 566    (mapc (lambda (e)
 567            (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
 568          es)))
 569
 570
 571
 572
 573
 574 ;;; ***************************************************************************
 575 ;;; *                              End of File                                *
 576 ;;; ***************************************************************************