dev/graph-algorithms.lisp

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