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
 232 (defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
 233   (< (weight e1) (weight e2)))
 234
 235 ;;; ---------------------------------------------------------------------------
 236 ;;; minumum spanning tree
 237 ;;; ---------------------------------------------------------------------------
 238
 239
 240 (defmethod minimum-spanning-tree ((graph basic-graph)
 241                                   &key
 242                                   (edge-sorter #'edge-lessp-by-weight))
 243   (bind ((result nil))
 244     (iterate-vertexes
 245      graph
 246      (lambda (v)
 247        (mst-make-set v)))
 248
 249     (loop for edge in (sort (edges graph) edge-sorter) do
 250           (bind ((v1 (source-vertex edge))
 251                  (v2 (target-vertex edge)))
 252
 253             (unless (eq (mst-find-set v1)
 254                         (mst-find-set v2))
 255               (push edge result)
 256               (mst-tree-union v1 v2)))
 257           finally
 258           (return
 259            (cond ((= (length result) (- (length (vertexes graph)) 1))
 260                   (values t result))
 261                  (t (values nil result)))))))
 262
 263 ;;; ---------------------------------------------------------------------------
 264
 265 #+ignore ;;; shoot
 266 (defmethod minimum-spanning-tree ((vertex-list list)
 267                                   &key
 268                                   (edge-sorter #'edge-lessp-by-weight))
 269   (bind ((result nil)
 270          (v-edges (remove-duplicates
 271                    (flatten (mapcar #'edges vertex-list)) :test #'eq)))
 272
 273     (iterate-container
 274      vertex-list
 275      (lambda (v)
 276        (mst-make-set v)))
 277
 278     (loop for edge in (sort v-edges edge-sorter) do
 279           (bind ((v1 (source-vertex edge))
 280                  (v2 (target-vertex edge))
 281                  (v1-set (mst-find-set v1))
 282                  (v2-set (mst-find-set v2)))
 283
 284             (when (or (not v1-set)
 285                            (not v2-set))
 286               (return-from minimum-spanning-tree nil))
 287
 288
 289             (unless (eq (mst-find-set v1)
 290                         (mst-find-set v2))
 291               (push edge result)
 292               (mst-tree-union v1 v2)))
 293           finally
 294           (return
 295            (cond ((= (length result) (- (length vertex-list) 1))
 296                   (values t result))
 297                  (t (values nil result)))))))
 298
 299 ;;; ---------------------------------------------------------------------------
 300 ;;; uses mst to determine if the graph is connected
 301 ;;; ---------------------------------------------------------------------------
 302
 303 (defmethod connected-graph-p ((graph basic-graph) &key
 304                               (edge-sorter 'edge-lessp-by-weight))
 305   (minimum-spanning-tree graph :edge-sorter edge-sorter))
 306
 307
 308 ;;; ---------------------------------------------------------------------------
 309
 310 #+test
 311 (bind ((g (make-container 'graph-container)))
 312   (add-edge-between-vertexes g :v :y :edge-type :directed)
 313   (add-edge-between-vertexes g :u :x :edge-type :directed)
 314   (add-edge-between-vertexes g :x :v :edge-type :directed)
 315   (add-edge-between-vertexes g :u :v :edge-type :directed)
 316   (add-edge-between-vertexes g :y :x :edge-type :directed)
 317   (add-edge-between-vertexes g :w :y :edge-type :directed)
 318   (add-edge-between-vertexes g :w :z :edge-type :directed)
 319   (add-edge-between-vertexes g :z :z :edge-type :directed
 320                              :if-duplicate-do :force)
 321   (minimum-spanning-tree g))
 322
 323 ;;; ---------------------------------------------------------------------------
 324 ;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
 325 ;;; a tree (still faster even if it does).  Will decide later if which to use
 326 ;;; ignoring for now -jjm
 327 ;;; ---------------------------------------------------------------------------
 328
 329 #+not-yet
 330 (defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
 331   (let ((a nil)
 332         (union (make-container 'union-find-container))
 333         (edges (sort (edges graph) #'< :key weight)))
 334     (iterate-vertexes
 335      graph (lambda (v) (insert-item union v)))
 336     (dolist (edge edges)
 337       (let ((node-1 (representative-node union (vertex-1 edge)))
 338             (node-2 (representative-node union (vertex-2 edge))))
 339         (unless (eq (find-set node-1) (find-set node-2))
 340           (graft-nodes node-1 node-2)
 341           (push edge a))))
 342
 343     (values a)))
 344
 345 ;;; ---------------------------------------------------------------------------
 346
 347 #+test
 348 (loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
 349       (fluid-bind (((random-seed *random-generator*) 1))
 350         (bind ((g (generate-undirected-graph-via-vertex-probabilities
 351                    *random-generator* (make-instance 'graph-container :default-edge-type :directed)
 352                    100
 353                    #(0.8 0.2)
 354                    #2A((0.2 0.1) (nil 0.2))
 355                    (lambda (kind count)
 356                      (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 357                   ))
 358           (timeit (:report :values)
 359                   (loop for n from 1 to 100 do
 360                         (funcall f g (lambda (a b)
 361                                        (declare (ignore a b))
 362                                        0)))))))
 363
 364 ;;; ---------------------------------------------------------------------------
 365 ;;; end minimum spanning tree
 366 ;;; ---------------------------------------------------------------------------
 367
 368
 369 ;;; ---------------------------------------------------------------------------
 370 ;;; depth-first-search - clrs2
 371 ;;; todo - figure out how to name this depth-first-search, which is already
 372 ;;; defined in search.lisp
 373 ;;; ---------------------------------------------------------------------------
 374
 375 ;;; ---------------------------------------------------------------------------
 376 ;;; should probably make this special
 377 ;;; ---------------------------------------------------------------------------
 378
 379 (defparameter *depth-first-search-timer* -1)
 380
 381 ;;; ---------------------------------------------------------------------------
 382 ;;; undirected edges are less than edges that are directed
 383 ;;; ---------------------------------------------------------------------------
 384
 385 #+ignore ;;; incorrect, methinks - jjm
 386 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 387   (cond ((or (every #'directed-edge-p (list e1 e2))
 388              (every #'undirected-edge-p (list e1 e2)))
 389          t)
 390         ((and (undirected-edge-p e1) (directed-edge-p e2))
 391          t)
 392         (t nil)))
 393
 394 (defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
 395   (and (undirected-edge-p e1) (directed-edge-p e2)))
 396
 397 ;;; ---------------------------------------------------------------------------
 398
 399 (defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
 400   (cond ((and (directed-edge-p edge)
 401               (eq vertex (source-vertex edge)))
 402          t)
 403         ((and (undirected-edge-p edge)
 404               (or (eq vertex (source-vertex edge))
 405                   (eq vertex (target-vertex edge))))
 406          t)
 407         (t nil)))
 408
 409 ;;; ---------------------------------------------------------------------------
 410 ;;; depth-first-search
 411 ;;; ---------------------------------------------------------------------------
 412
 413 (defmethod dfs ((graph basic-graph) (root t) fn &key
 414                 (out-edge-sorter #'edge-lessp-by-direction))
 415   (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
 416
 417 ;;; ---------------------------------------------------------------------------
 418
 419 (defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
 420                 (out-edge-sorter #'edge-lessp-by-direction))
 421   (setf *depth-first-search-timer* -1)
 422
 423   (iterate-vertexes
 424    graph
 425    (lambda (v)
 426      (setf (color v) :white
 427            (previous-node v) nil
 428            (discovery-time v) -1
 429            (finish-time v) -1)))
 430
 431   (iterate-edges
 432    graph
 433    (lambda (e)
 434      (setf (color e) nil)))
 435
 436   (loop with vl = (remove root (vertexes graph) :test #'eql)
 437         for v in (push root vl) do
 438         (when (eql (color v) :white)
 439           (dfs-visit graph v fn out-edge-sorter)))
 440
 441   (values
 442    (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
 443    graph))
 444
 445 ;;; ---------------------------------------------------------------------------
 446
 447 (defmethod dfs-visit ((graph graph-container) (u basic-vertex)
 448                                      fn sorter)
 449
 450
 451   (incf *depth-first-search-timer*)
 452   (setf (color u) :gray
 453         (discovery-time u) *depth-first-search-timer*)
 454
 455
 456   (loop for edge in (sort (collect-elements
 457                            (edges u)
 458                            :filter (lambda (e)
 459                                      (out-edge-for-vertex-p e u))) sorter) do
 460         (bind ((v (other-vertex edge u)))
 461
 462           (unless (color edge)
 463             (setf (color edge) (color v)))
 464
 465           (when (eql (color v) :white)
 466               (setf (previous-node v) u)
 467               (funcall fn v)
 468               (dfs-visit graph v fn sorter))))
 469
 470   (incf *depth-first-search-timer*)
 471
 472   (setf (color u) :black
 473         (finish-time u) *depth-first-search-timer*))
 474
 475 ;;; ---------------------------------------------------------------------------
 476 ;;; from clrs2
 477 ;;; ---------------------------------------------------------------------------
 478
 479 #+test
 480 (bind ((g (make-container 'graph-container)))
 481   (add-edge-between-vertexes g :v :y :edge-type :directed)
 482   (add-edge-between-vertexes g :u :x :edge-type :directed)
 483   (add-edge-between-vertexes g :x :v :edge-type :directed)
 484   (add-edge-between-vertexes g :u :v :edge-type :directed)
 485   (add-edge-between-vertexes g :y :x :edge-type :directed)
 486   (add-edge-between-vertexes g :w :y :edge-type :directed)
 487   (add-edge-between-vertexes g :w :z :edge-type :directed)
 488   (add-edge-between-vertexes g :z :z :edge-type :directed
 489                              :if-duplicate-do :force)
 490   (assert (equal '(:X :Y :V :U :Z :W)
 491                  (mapcar #'element (dfs g :u #'identity)))))
 492
 493 ;;; ---------------------------------------------------------------------------
 494
 495 (defmethod dfs-tree-edge-p ((edge graph-container-edge))
 496   (eql (color edge) :white))
 497
 498 ;;; ---------------------------------------------------------------------------
 499
 500 (defmethod dfs-back-edge-p ((edge graph-container-edge))
 501   (eql (color edge) :gray))
 502
 503 ;;; ---------------------------------------------------------------------------
 504 ;;; not correct - has to look at combination of discovery-time and finish-time
 505 ;;; ---------------------------------------------------------------------------
 506
 507 (defmethod dfs-forward-edge-p ((edge graph-container-edge))
 508   (warn "implementation is not correct.")
 509   (unless (and (dfs-tree-edge-p edge)
 510                (dfs-back-edge-p edge))
 511     (< (discovery-time (source-vertex edge))
 512        (discovery-time (target-vertex edge)))))
 513
 514 ;;; ---------------------------------------------------------------------------
 515 ;;; not correct - has to look at combination of discovery-time and finish-time
 516 ;;; ---------------------------------------------------------------------------
 517
 518 (defmethod dfs-cross-edge-p ((edge graph-container-edge))
 519   (warn "implementation is not correct.")
 520   (unless (and (dfs-tree-edge-p edge)
 521                (dfs-back-edge-p edge))
 522     (> (discovery-time (source-vertex edge))
 523        (discovery-time (target-vertex edge)))))
 524
 525 ;;; ---------------------------------------------------------------------------
 526
 527 (defmethod dfs-edge-type ((edge graph-container-edge))
 528   (cond ((dfs-tree-edge-p edge)
 529          :tree)
 530         ((dfs-back-edge-p edge)
 531          :back)
 532         ((dfs-forward-edge-p edge)
 533          :forward)
 534         ((dfs-cross-edge-p edge)
 535          :cross)
 536         (t nil)))
 537
 538 ;;; ---------------------------------------------------------------------------
 539 ;;; end dfs
 540 ;;; ---------------------------------------------------------------------------
 541
 542 ;;; ---------------------------------------------------------------------------
 543 ;;; mapping functions
 544 ;;; ---------------------------------------------------------------------------
 545
 546 ;;; ---------------------------------------------------------------------------
 547 ;;; over vertexes
 548 ;;; ---------------------------------------------------------------------------
 549
 550 (defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
 551   (bind ((vertex-count (size graph))
 552          (symbols (make-list k :initial-element vertex-count))
 553          (vertexes (vertexes graph)))
 554     (iterate-over-indexes
 555      symbols
 556      (lambda (vertex-indexes)
 557        (when (apply #'< vertex-indexes)
 558          (funcall fn (mapcar (lambda (vertex-index)
 559                                (nth-element vertexes vertex-index))
 560                              vertex-indexes)))))))
 561
 562 ;;; ---------------------------------------------------------------------------
 563
 564 #+test
 565 (bind ((result nil)
 566        (g (make-container 'graph-container)))
 567   (add-edge-between-vertexes g :u :v :edge-type :directed)
 568   (add-edge-between-vertexes g :u :x :edge-type :directed)
 569   (add-edge-between-vertexes g :x :v :edge-type :directed)
 570   (add-edge-between-vertexes g :v :y :edge-type :directed)
 571   (add-edge-between-vertexes g :y :x :edge-type :directed)
 572   (add-edge-between-vertexes g :w :y :edge-type :directed)
 573   (add-edge-between-vertexes g :w :z :edge-type :directed)
 574
 575   (map-over-all-combinations-of-k-vertexes
 576    g
 577    4
 578    (lambda (vertex-list)
 579      (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
 580        (when (mst-kruskal graph-from-vertexes #'identity-sorter)
 581          (push graph-from-vertexes result)))))
 582   result)
 583
 584 ;;; ---------------------------------------------------------------------------
 585 ;;; over edges
 586 ;;; todo: merge these two defs
 587 ;;; ---------------------------------------------------------------------------
 588
 589 (defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
 590   (bind ((edge-count (edge-count graph))
 591          (symbols (make-list k :initial-element edge-count))
 592          (edges (edges graph)))
 593     (print symbols)
 594     (iterate-over-indexes
 595      symbols
 596      (lambda (edge-indexes)
 597        (when (apply #'< edge-indexes)
 598          (funcall fn (mapcar (lambda (edge-index)
 599                                (nth-element edges edge-index))
 600                              edge-indexes)))))))
 601
 602 ;;; ---------------------------------------------------------------------------
 603
 604 (defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
 605   (bind ((edge-count (edge-count vertex))
 606          (symbols (make-list k :initial-element edge-count))
 607          (edges (edges vertex)))
 608     (print symbols)
 609     (iterate-over-indexes
 610      symbols
 611      (lambda (edge-indexes)
 612        (when (apply #'< edge-indexes)
 613          (funcall fn (mapcar (lambda (edge-index)
 614                                (nth-element edges edge-index))
 615                              edge-indexes)))))))
 616 ;;; ---------------------------------------------------------------------------
 617
 618 #+test
 619 (map-over-all-combinations-of-k-edges
 620  (generate-undirected-graph-via-verex-probabilities
 621   *random-generator* 'graph-container
 622   10
 623   #(0.8 0.2)
 624   #2A((0.2 0.1) (nil 0.2))
 625   (lambda (kind count)
 626     (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
 627  2
 628  (lambda (es)
 629    (format t "~%")
 630    (mapc (lambda (e)
 631            (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
 632          es)))
 633
 634
 635
 636
 637
 638 ;;; ***************************************************************************
 639 ;;; *                              End of File                                *
 640 ;;; ***************************************************************************