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