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
 150            (push (subgraph-containing graph (element component)
 151                                       most-positive-fixnum)
 152                  result)))))
 153
 154     result))
 155
 156
 157
 158 ;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
 159
 160 (defmethod mst-find-set ((vertex basic-vertex))
 161   #+ignore
 162   (unless (previous-node vertex)
 163     (return-from mst-find-set nil))
 164   (unless (eq vertex (previous-node vertex))
 165     (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
 166   (previous-node vertex))
 167
 168
 169 (defmethod mst-make-set ((vertex basic-vertex))
 170   (setf (previous-node vertex) vertex
 171         (rank vertex) 0))
 172
 173
 174 (defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
 175   (mst-link (mst-find-set v1) (mst-find-set v2)))
 176
 177
 178 (defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
 179   (cond ((> (rank v1) (rank v2))
 180          (setf (previous-node v2) v1))
 181         (t (setf (previous-node v1) v2)
 182            (when (= (rank v1) (rank v2))
 183              (incf (rank v2))))))
 184
 185 ;;; jjm's implementation of mst depends on this
 186 ;;; todo - figure out some what to add and edge we create to a graph rather
 187 ;;; than always using add-edge-between-vertexes interface
 188
 189 (defmethod add-edges-to-graph ((graph basic-graph) (edges list)
 190                                &key (if-duplicate-do :ignore))
 191   (iterate-elements
 192    edges
 193    (lambda (edge)
 194      (let ((v1 (element (source-vertex edge)))
 195            (v2 (element (target-vertex edge))))
 196        (add-edge-between-vertexes
 197         graph v1 v2 :edge-class (type-of edge)
 198         :edge-type (if (directed-edge-p edge)
 199                      :directed
 200                      :undirected)
 201         :value (value edge)
 202         :edge-id (edge-id edge)
 203         :element (element edge)
 204         :tag (tag edge)
 205         :graph graph
 206         :color (color edge)
 207         :if-duplicate-do if-duplicate-do))))
 208   graph)
 209
 210
 211 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
 212   (< (weight e1) (weight e2)))
 213
 214 ;;; minumum spanning tree
 215
 216
 217 (defmethod minimum-spanning-tree ((graph basic-graph)
 218                                   &key
 219                                   (edge-sorter #'edge-lessp-by-weight))
 220   (let ((result nil))
 221     (iterate-vertexes
 222      graph
 223      (lambda (v)
 224        (mst-make-set v)))
 225
 226     (loop for edge in (sort (edges graph) edge-sorter) do
 227           (let ((v1 (source-vertex edge))
 228                  (v2 (target-vertex edge)))
 229
 230             (unless (eq (mst-find-set v1)
 231                         (mst-find-set v2))
 232               (push edge result)
 233               (mst-tree-union v1 v2)))
 234           finally
 235           (return
 236            (cond ((= (length result) (- (length (vertexes graph)) 1))
 237                   (values t result))
 238                  (t (values nil result)))))))
 239
 240
 241 #+ignore ;;; shoot
 242 (defmethod minimum-spanning-tree ((vertex-list list)
 243                                   &key
 244                                   (edge-sorter #'edge-lessp-by-weight))
 245   (let ((result nil)
 246          (v-edges (remove-duplicates
 247                    (flatten (mapcar #'edges vertex-list)) :test #'eq)))
 248
 249     (iterate-container
 250      vertex-list
 251      (lambda (v)
 252        (mst-make-set v)))
 253
 254     (loop for edge in (sort v-edges edge-sorter) do
 255           (let ((v1 (source-vertex edge))
 256                 (v2 (target-vertex edge))
 257                 (v1-set (mst-find-set v1))
 258                 (v2-set (mst-find-set v2)))
 259
 260             (when (or (not v1-set)
 261                            (not v2-set))
 262               (return-from minimum-spanning-tree nil))
 263
 264
 265             (unless (eq (mst-find-set v1)
 266                         (mst-find-set v2))
 267               (push edge result)
 268               (mst-tree-union v1 v2)))
 269           finally
 270           (return
 271            (cond ((= (length result) (- (length vertex-list) 1))
 272                   (values t result))
 273                  (t (values nil result)))))))
 274
 275 ;;; uses mst to determine if the graph is connected
 276
 277 (defmethod connected-graph-p ((graph basic-graph) &key
 278                               (edge-sorter 'edge-lessp-by-weight))
 279   (minimum-spanning-tree graph :edge-sorter edge-sorter))
 280
 281
 282
 283 #+test
 284 (let ((g (make-container 'graph-container)))
 285   (add-edge-between-vertexes g :v :y :edge-type :directed)
 286   (add-edge-between-vertexes g :u :x :edge-type :directed)
 287   (add-edge-between-vertexes g :x :v :edge-type :directed)
 288   (add-edge-between-vertexes g :u :v :edge-type :directed)
 289   (add-edge-between-vertexes g :y :x :edge-type :directed)
 290   (add-edge-between-vertexes g :w :y :edge-type :directed)
 291   (add-edge-between-vertexes g :w :z :edge-type :directed)
 292   (add-edge-between-vertexes g :z :z :edge-type :directed
 293                              :if-duplicate-do :force)
 294   (minimum-spanning-tree g))
 295
 296 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
 297 ;;; a tree (still faster even if it does).  Will decide later if which to use
 298 ;;; ignoring for now -jjm
 299
 300 #+not-yet
 301 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
 302   (let ((a nil)
 303         (union (make-container 'union-find-container))
 304         (edges (sort (edges graph) #'< :key weight)))
 305     (iterate-vertexes
 306      graph (lambda (v) (insert-item union v)))
 307     (dolist (edge edges)
 308       (let ((node-1 (representative-node union (vertex-1 edge)))
 309             (node-2 (representative-node union (vertex-2 edge))))
 310         (unless (eq (find-set node-1) (find-set node-2))
 311           (graft-nodes node-1 node-2)
 312           (push edge a))))
 313
 314     (values a)))
 315
 316
 317 #+test
 318 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
 319       (fluid-bind (((random-seed *random-generator*) 1))
 320         (bind ((g (generate-undirected-graph-via-vertex-probabilities
 321                    *random-generator* (make-instance 'graph-container :default-edge-type :directed)
 322                    100
 323                    #(0.8 0.2)
 324                    #2A((0.2 0.1) (nil 0.2))
 325                    (lambda (kind count)
 326                      (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 327                   ))
 328           (timeit (:report :values)
 329                   (loop for n from 1 to 100 do
 330                         (funcall f g (lambda (a b)
 331                                        (declare (ignore a b))
 332                                        0)))))))
 333
 334 ;;; end minimum spanning tree
 335
 336
 337 ;;; depth-first-search - clrs2
 338 ;;; todo - figure out how to name this depth-first-search, which is already
 339 ;;; defined in search.lisp
 340
 341 ;;; should probably make this special
 342
 343 (defparameter *depth-first-search-timer* -1)
 344
 345 ;;; undirected edges are less than edges that are directed
 346
 347 #+ignore ;;; incorrect, methinks - jjm
 348 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 349   (cond ((or (every #'directed-edge-p (list e1 e2))
 350              (every #'undirected-edge-p (list e1 e2)))
 351          t)
 352         ((and (undirected-edge-p e1) (directed-edge-p e2))
 353          t)
 354         (t nil)))
 355
 356 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 357   (and (undirected-edge-p e1) (directed-edge-p e2)))
 358
 359
 360 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
 361   (cond ((and (directed-edge-p edge)
 362               (eq vertex (source-vertex edge)))
 363          t)
 364         ((and (undirected-edge-p edge)
 365               (or (eq vertex (source-vertex edge))
 366                   (eq vertex (target-vertex edge))))
 367          t)
 368         (t nil)))
 369
 370 ;;; depth-first-search
 371
 372 (defmethod dfs ((graph basic-graph) (root t) fn &key
 373                 (out-edge-sorter #'edge-lessp-by-direction))
 374   (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
 375
 376
 377 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
 378                 (out-edge-sorter #'edge-lessp-by-direction))
 379   (setf *depth-first-search-timer* -1)
 380
 381   (iterate-vertexes
 382    graph
 383    (lambda (v)
 384      (setf (color v) :white
 385            (previous-node v) nil
 386            (discovery-time v) -1
 387            (finish-time v) -1)))
 388
 389   (iterate-edges
 390    graph
 391    (lambda (e)
 392      (setf (color e) nil)))
 393
 394   (loop with vl = (remove root (vertexes graph) :test #'eql)
 395         for v in (push root vl) do
 396         (when (eql (color v) :white)
 397           (dfs-visit graph v fn out-edge-sorter)))
 398
 399   (values
 400    (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
 401    graph))
 402
 403
 404 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
 405                                      fn sorter)
 406
 407
 408   (incf *depth-first-search-timer*)
 409   (setf (color u) :gray
 410         (discovery-time u) *depth-first-search-timer*)
 411
 412
 413   (loop for edge in (sort (collect-elements
 414                            (edges u)
 415                            :filter (lambda (e)
 416                                      (out-edge-for-vertex-p e u))) sorter) do
 417         (let ((v (other-vertex edge u)))
 418
 419           (unless (color edge)
 420             (setf (color edge) (color v)))
 421
 422           (when (eql (color v) :white)
 423               (setf (previous-node v) u)
 424               (funcall fn v)
 425               (dfs-visit graph v fn sorter))))
 426
 427   (incf *depth-first-search-timer*)
 428
 429   (setf (color u) :black
 430         (finish-time u) *depth-first-search-timer*))
 431
 432 ;;; from clrs2
 433
 434 #+test
 435 (let ((g (make-container 'graph-container)))
 436   (add-edge-between-vertexes g :v :y :edge-type :directed)
 437   (add-edge-between-vertexes g :u :x :edge-type :directed)
 438   (add-edge-between-vertexes g :x :v :edge-type :directed)
 439   (add-edge-between-vertexes g :u :v :edge-type :directed)
 440   (add-edge-between-vertexes g :y :x :edge-type :directed)
 441   (add-edge-between-vertexes g :w :y :edge-type :directed)
 442   (add-edge-between-vertexes g :w :z :edge-type :directed)
 443   (add-edge-between-vertexes g :z :z :edge-type :directed
 444                              :if-duplicate-do :force)
 445   (assert (equal '(:X :Y :V :U :Z :W)
 446                  (mapcar #'element (dfs g :u #'identity)))))
 447
 448
 449 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
 450   (eql (color edge) :white))
 451
 452
 453 (defmethod dfs-back-edge-p ((edge graph-container-edge))
 454   (eql (color edge) :gray))
 455
 456 ;;; not correct - has to look at combination of discovery-time and finish-time
 457
 458 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
 459   (warn "implementation is not correct.")
 460   (unless (and (dfs-tree-edge-p edge)
 461                (dfs-back-edge-p edge))
 462     (< (discovery-time (source-vertex edge))
 463        (discovery-time (target-vertex edge)))))
 464
 465 ;;; not correct - has to look at combination of discovery-time and finish-time
 466
 467 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
 468   (warn "implementation is not correct.")
 469   (unless (and (dfs-tree-edge-p edge)
 470                (dfs-back-edge-p edge))
 471     (> (discovery-time (source-vertex edge))
 472        (discovery-time (target-vertex edge)))))
 473
 474
 475 (defmethod dfs-edge-type ((edge graph-container-edge))
 476   (cond ((dfs-tree-edge-p edge)
 477          :tree)
 478         ((dfs-back-edge-p edge)
 479          :back)
 480         ((dfs-forward-edge-p edge)
 481          :forward)
 482         ((dfs-cross-edge-p edge)
 483          :cross)
 484         (t nil)))
 485
 486 ;;; end dfs
 487
 488 ;;; mapping functions
 489
 490 ;;; over vertexes
 491
 492 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
 493   (let* ((vertex-count (size graph))
 494          (symbols (make-list k :initial-element vertex-count))
 495          (vertexes (vertexes graph)))
 496     (iterate-over-indexes
 497      symbols
 498      (lambda (vertex-indexes)
 499        (when (apply #'< vertex-indexes)
 500          (funcall fn (mapcar (lambda (vertex-index)
 501                                (nth-element vertexes vertex-index))
 502                              vertex-indexes)))))))
 503
 504
 505 #+test
 506 (let ((result nil)
 507        (g (make-container 'graph-container)))
 508   (add-edge-between-vertexes g :u :v :edge-type :directed)
 509   (add-edge-between-vertexes g :u :x :edge-type :directed)
 510   (add-edge-between-vertexes g :x :v :edge-type :directed)
 511   (add-edge-between-vertexes g :v :y :edge-type :directed)
 512   (add-edge-between-vertexes g :y :x :edge-type :directed)
 513   (add-edge-between-vertexes g :w :y :edge-type :directed)
 514   (add-edge-between-vertexes g :w :z :edge-type :directed)
 515
 516   (map-over-all-combinations-of-k-vertexes
 517    g
 518    4
 519    (lambda (vertex-list)
 520      (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
 521        (when (mst-kruskal graph-from-vertexes #'identity-sorter)
 522          (push graph-from-vertexes result)))))
 523   result)
 524
 525 ;;; over edges
 526 ;;; todo: merge these two defs
 527
 528 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
 529   (let* ((edge-count (edge-count graph))
 530          (symbols (make-list k :initial-element edge-count))
 531          (edges (edges graph)))
 532     (print symbols)
 533     (iterate-over-indexes
 534      symbols
 535      (lambda (edge-indexes)
 536        (when (apply #'< edge-indexes)
 537          (funcall fn (mapcar (lambda (edge-index)
 538                                (nth-element edges edge-index))
 539                              edge-indexes)))))))
 540
 541
 542 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
 543   (let* ((edge-count (edge-count vertex))
 544          (symbols (make-list k :initial-element edge-count))
 545          (edges (edges vertex)))
 546     ;(print symbols)
 547     (iterate-over-indexes
 548      symbols
 549      (lambda (edge-indexes)
 550        (when (apply #'< edge-indexes)
 551          (funcall fn (mapcar (lambda (edge-index)
 552                                (nth-element edges edge-index))
 553                              edge-indexes)))))))
 554
 555 #+test
 556 (map-over-all-combinations-of-k-edges
 557  (generate-undirected-graph-via-verex-probabilities
 558   *random-generator* 'graph-container
 559   10
 560   #(0.8 0.2)
 561   #2A((0.2 0.1) (nil 0.2))
 562   (lambda (kind count)
 563     (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 564  2
 565  (lambda (es)
 566    (format t "~%")
 567    (mapc (lambda (e)
 568            (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
 569          es)))
 570
 571
 572
 573
 574
 575 ;;; ***************************************************************************
 576 ;;; *                              End of File                                *
 577 ;;; ***************************************************************************