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