share/graphs/graph_core.lisp

   1 ;;;
   2 ;;;  GRAPHS - graph theory package for Maxima
   3 ;;;
   4 ;;;  Copyright (C) 2007-2011 Andrej Vodopivec <andrej.vodopivec@gmail.com>
   5 ;;;
   6 ;;;  This program is free software; you can redistribute it and/or modify
   7 ;;;  it under the terms of the GNU General Public License as published by
   8 ;;;  the Free Software Foundation; either version 2 of the License, or
   9 ;;;  (at your option) any later version.
  10 ;;;
  11 ;;;  This program is distributed in the hope that it will be useful,
  12 ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;  GNU General Public License for more details.
  15 ;;;
  16 ;;;  You should have received a copy of the GNU General Public License
  17 ;;;  along with this program; if not, write to the Free Software
  18 ;;;  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  19 ;;;
  20
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;;
  24 ;;; graph and digraph datastructure
  25 ;;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27
  28 (in-package :maxima)
  29
  30 ($put '$graphs 2.0 '$version)
  31
  32 (defstruct (graph
  33              (:print-function
  34               (lambda (stru strm depth)
  35                 (format strm "GRAPH(~a vertices, ~a edges)" (graph-order stru) (graph-size stru)))))
  36   (size 0)
  37   (order 0)
  38   (vertices ())
  39   (vertex-labels (make-hash-table))
  40   (vertex-positions)
  41   (edges ())
  42   (edge-weights (make-hash-table :test #'equal))
  43   (neighbors (make-hash-table)))
  44
  45 (defstruct (digraph
  46              (:print-function
  47               (lambda (stru strm depth)
  48                 (format strm "DIGRAPH(~a vertices, ~a arcs)" (digraph-order stru) (digraph-size stru)))))
  49   (size 0)
  50   (order 0)
  51   (vertices ())
  52   (vertex-labels (make-hash-table))
  53   (edges ())
  54   (vertex-positions)
  55   (edge-weights (make-hash-table :test #'equal))
  56   (in-neighbors (make-hash-table))
  57   (out-neighbors (make-hash-table)))
  58
  59 (defun require-graph (m ar gr)
  60   (unless (graph-p gr)
  61     ($error (format nil "Argument ~a to `~a' is not a graph:" ar m) gr)))
  62
  63 (defun require-digraph (m ar gr)
  64   (unless (digraph-p gr)
  65     ($error (format nil "Argument ~a to `~a' is not a directed graph:" ar m) gr)))
  66
  67 (defun require-graph-or-digraph (m ar gr)
  68   (unless (or (graph-p gr) (digraph-p gr))
  69     ($error (format nil "Argument ~a to `~a' is not a graph:" ar m) gr)))
  70
  71 (defmfun $print_graph (gr)
  72   (require-graph-or-digraph 'print_graph 1 gr)
  73   (cond
  74     ((graph-p gr)
  75      (format t "~%Graph on ~d vertices with ~d edges."
  76              (graph-order gr) (graph-size gr))
  77      (when (> (graph-order gr) 0 )
  78        (format t "~%Adjacencies:"))
  79      (dolist (v (graph-vertices gr))
  80        (format t "~% ~2d :" v)
  81        (dolist (u (neighbors v gr))
  82          (format t " ~2d" u))))
  83     (t
  84      (format t "~%Digraph on ~d vertices with ~d arcs."
  85              (digraph-order gr) (digraph-size gr))
  86      (when (> (digraph-order gr) 0 )
  87        (format t "~%Adjacencies:"))
  88      (dolist (v (digraph-vertices gr))
  89        (format t "~% ~2d :" v)
  90        (dolist (u (out-neighbors v gr))
  91          (format t " ~2d" u)))))
  92   (format t "~%")
  93   '$done)
  94
  95 (defmfun $is_graph (x)
  96   (graph-p x))
  97
  98 (defmfun $is_digraph (x)
  99   (digraph-p x))
 100
 101 (defmfun $is_graph_or_digraph (x)
 102   (or (graph-p x) (digraph-p x)))
 103
 104 (defmfun $graph_order (gr)
 105   (require-graph-or-digraph 'graph_order 1 gr)
 106   (if (graph-p gr)
 107       (graph-order gr)
 108       (digraph-order gr)))
 109
 110 (defmfun $graph_size (gr)
 111   (require-graph-or-digraph 'graph_size 1 gr)
 112   (if (graph-p gr)
 113       (graph-size gr)
 114       (digraph-size gr)))
 115
 116 (defmfun $get_positions (gr)
 117   (require-graph-or-digraph 'get_positions 1 gr)
 118   (if (graph-p gr)
 119       (graph-vertex-positions gr)
 120       (digraph-vertex-positions gr)))
 121
 122 (defmfun $set_positions (pos gr)
 123   (require-graph-or-digraph 'set_positions 2 gr)
 124   (if (graph-p gr)
 125       (setf (graph-vertex-positions gr) pos)
 126       (setf (digraph-vertex-positions gr) pos)))
 127
 128 (defmfun $copy_graph (gr)
 129   (require-graph-or-digraph 'copy_graph 1 gr)
 130   (if (graph-p gr)
 131       (let ((g (make-graph)))
 132         (dolist (v (graph-vertices gr))
 133           (add-vertex v g)
 134           (let ((l (get-vertex-label v gr)))
 135             (if l (set-vertex-label v l g))))
 136         (dolist (e (graph-edges gr))
 137           (add-edge e g)
 138           (let ((w (get-edge-weight e gr)))
 139             (if w (set-edge-weight e w g))))
 140         ($set_positions ($get_positions gr) g)
 141         g)
 142       (let ((g (make-digraph)))
 143         (dolist (v (digraph-vertices gr))
 144           (add-vertex v g)
 145           (let ((l (get-vertex-label v gr)))
 146             (if l (set-vertex-label v l g))))
 147         (dolist (e (digraph-edges gr))
 148           (add-edge e g)
 149           (let ((w (get-edge-weight e gr)))
 150             (if w (set-edge-weight e w g))))
 151         ($set_positions ($get_positions gr) g)
 152         g) ))
 153
 154 (defmfun $new_graph ()
 155   (make-graph))
 156
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158 ;;;
 159 ;;; vertex operations
 160 ;;;
 161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 162
 163 (defmfun $vertices (gr)
 164   (require-graph-or-digraph 'vertices 1 gr)
 165   (let ((vrt (vertices gr)))
 166     `((mlist simp) ,@(copy-list vrt))))
 167
 168 (defun vertices (gr)
 169   (if (graph-p gr) (graph-vertices gr) (digraph-vertices gr)))
 170
 171 (defun require-vertex (m i v)
 172   (unless (integerp v)
 173     ($error "Argument" i "to" m "is not a valid vertex.")))
 174
 175 (defun is-vertex-in-graph (i gr)
 176   (not (equal (gethash i
 177                        (if (graph-p gr)
 178                            (graph-neighbors gr)
 179                            (digraph-out-neighbors gr))
 180                        'not-in-graph)
 181               'not-in-graph)))
 182
 183 (defun require-vertex-in-graph (m i gr)
 184   (unless (is-vertex-in-graph i gr)
 185     ($error m ": vertex not in graph.")))
 186
 187 (defmfun $is_vertex_in_graph (i gr)
 188   (require-vertex 'vertex_in_graph 1 i)
 189   (require-graph-or-digraph 'vertex_in_graph 2 gr)
 190   (is-vertex-in-graph i gr))
 191
 192 (defmfun $add_vertex (i &optional gr)
 193   (unless gr
 194     (setq gr i)
 195     (setq i (1+ (apply #'max (vertices gr)))))
 196   (require-vertex 'add_vertex 1 i)
 197   (require-graph-or-digraph 'add_vertex 2 gr)
 198   (when (is-vertex-in-graph i gr)
 199     ($error "add_vertex: vertex is already in the graph!"))
 200   (add-vertex i gr)
 201   i)
 202
 203 (defmfun $add_vertices (vl gr)
 204   (require-graph-or-digraph 'add_vertices 2 gr)
 205   (unless (or (integerp vl) ($listp vl))
 206     ($error "Argument 1 to add_vertices is not a list."))
 207   (if ($listp vl)
 208       (dolist (v (cdr vl))
 209         ($add_vertex v gr))
 210       (let* ((n vl))
 211         (setq vl ())
 212         (dotimes (i n)
 213           (setf vl (cons ($add_vertex gr) vl)))
 214         (setf vl (cons '(mlist simp) (reverse vl)))))
 215   vl)
 216
 217 (defun add-vertex (i gr)
 218   (if (graph-p gr)
 219       (progn
 220         (incf (graph-order gr))
 221         (push i (graph-vertices gr))
 222         (setf (graph-vertex-positions gr) nil)
 223         (setf (gethash i (graph-neighbors gr)) ()))
 224       (progn
 225         (incf (digraph-order gr))
 226         (push i (digraph-vertices gr))
 227         (setf (digraph-vertex-positions gr) nil)
 228         (setf (gethash i (digraph-in-neighbors gr)) ())
 229         (setf (gethash i (digraph-out-neighbors gr)) ())) ))
 230
 231 (defun neighbors (i gr)
 232   (gethash i (if (graph-p gr)
 233                  (graph-neighbors gr)
 234                  (digraph-out-neighbors gr))) )
 235
 236 (defun in-neighbors (i gr)
 237   (gethash i (digraph-in-neighbors gr)))
 238
 239 (defun out-neighbors (i gr)
 240   (gethash i (digraph-out-neighbors gr)))
 241
 242 (defmfun $neighbors (i gr)
 243   (require-vertex 'neighbors 1 i)
 244   (require-graph 'neighbors 2 gr)
 245   (require-vertex-in-graph 'neighbors i gr)
 246   `((mlist simp) ,@(copy-list (neighbors i gr))))
 247
 248 (defmfun $out_neighbors (i gr)
 249   (require-vertex 'out_neighbors 1 i)
 250   (require-digraph 'out_neighbors 2 gr)
 251   (require-vertex-in-graph 'out_neighbors i gr)
 252   `((mlist simp) ,@(copy-list (out-neighbors i gr))))
 253
 254 (defmfun $in_neighbors (i gr)
 255   (require-vertex 'in_neighbors 1 i)
 256   (require-digraph 'in_neighbors 2 gr)
 257   (require-vertex-in-graph 'in_neighbors i gr)
 258   `((mlist simp) ,@(copy-list (in-neighbors i gr))))
 259
 260 (defmfun $degree_sequence (gr)
 261   (require-graph 'degree_sequence 1 gr)
 262   (let ((s ()))
 263     (dolist (v (graph-vertices gr))
 264       (push (length (neighbors v gr)) s))
 265     (setq s (sort s #'<))
 266     `((mlist simp) ,@s)))
 267
 268 (defmfun $remove_vertex (v gr)
 269   (require-vertex 'remove_vertex 1 v)
 270   (require-graph-or-digraph 'remove_vertex 2 gr)
 271   (require-vertex-in-graph 'remove_vertex v gr)
 272   (clear-vertex-label v gr)
 273   (remove-vertex v gr))
 274
 275 (defmfun $remove_vertices (vl gr)
 276   (require-graph-or-digraph 'remove_vertices 2 gr)
 277   (when (not ($listp vl))
 278     ($error "Argument 1 to remove_vertices is not a list."))
 279   (dolist (v (cdr vl))
 280     ($remove_vertex v gr))
 281   '$done)
 282
 283 (defun remove-vertex (v gr)
 284   (if (graph-p gr)
 285       (progn
 286         (dolist (u (neighbors v gr))
 287           (let ((e (list (min u v) (max u v))))
 288             (remove-edge e gr)))
 289         (clear-vertex-label v gr)
 290         (when (graph-vertex-positions gr)
 291           (setf (graph-vertex-positions gr)
 292                 (cons '(mlist simp) (remove-if (lambda (x) (= (cadr x) v))
 293                                                (cdr (graph-vertex-positions gr))))))
 294         (setf (graph-vertices gr) (remove v (graph-vertices gr) :count 1))
 295         (remhash v (graph-neighbors gr))
 296         (decf (graph-order gr)))
 297       (progn
 298         (dolist (u (out-neighbors v gr))
 299           (remove-edge (list v u) gr))
 300         (dolist (u (in-neighbors v gr))
 301           (remove-edge (list u v) gr))
 302         (clear-vertex-label v gr)
 303         (when (digraph-vertex-positions gr)
 304           (setf (digraph-vertex-positions gr)
 305                 (cons '(mlist simp) (remove-if (lambda (x) (= (cadr x) v))
 306                                                (cdr (digraph-vertex-positions gr))))))
 307         (setf (digraph-vertices gr) (remove v (digraph-vertices gr) :count 1))
 308         (remhash v (digraph-in-neighbors gr))
 309         (remhash v (digraph-out-neighbors gr))
 310         (decf (digraph-order gr))))
 311   '$done)
 312
 313 (defmfun $first_vertex (gr)
 314   (require-graph-or-digraph 'first_vertex 1 gr)
 315   (cond
 316     ((= 0 (if (graph-p gr) (graph-order gr) (digraph-order gr)))
 317      ($error "first_vertex: no first vertex in an empty graph."))
 318     (t (first (vertices gr)))))
 319
 320 (defmfun $max_degree (gr)
 321   (require-graph 'max_degree 1 gr)
 322   (cond
 323     ((= 0 (graph-order gr))
 324      ($error "max_degree: no max degree in an empty graph."))
 325     (t
 326      (let* ((v (first (graph-vertices gr))) (d (length (neighbors v gr))))
 327        (dolist (u (graph-vertices gr))
 328          (when (> (length (neighbors u gr)) d)
 329            (setq d (length (neighbors u gr)))
 330            (setq v u)))
 331        `((mlist simp) ,d ,v)))))
 332
 333 (defmfun $min_degree (gr)
 334   (require-graph 'min_degree 1 gr)
 335   (cond
 336     ((= 0 (graph-order gr))
 337      ($error "min_degree: no min degree in an empty graph."))
 338     (t
 339      (let* ((v (first (graph-vertices gr))) (d (length (neighbors v gr))))
 340        (dolist (u (graph-vertices gr))
 341          (when (< (length (neighbors u gr)) d)
 342            (setq d (length (neighbors u gr)))
 343            (setq v u)))
 344        `((mlist simp) ,d ,v)))))
 345
 346 (defmfun $average_degree (gr)
 347   (require-graph 'average_degee 1 gr)
 348   (m* 2 (m// (graph-size gr) (graph-order gr))))
 349
 350 (defmfun $vertex_degree (v gr)
 351   (require-vertex 'vertex_degree 1 v)
 352   (require-graph 'vertex_degree 2 gr)
 353   (require-vertex-in-graph 'vertex_degree v gr)
 354   (length (neighbors v gr)))
 355
 356 (defmfun $vertex_in_degree (v gr)
 357   (require-vertex 'vertex_in_degree 1 v)
 358   (require-digraph 'vertex_in_degree 2 gr)
 359   (require-vertex-in-graph 'vertex_in_degree v gr)
 360   (length (in-neighbors v gr)))
 361
 362 (defmfun $vertex_out_degree (v gr)
 363   (require-vertex 'vertex_out_degree 1 v)
 364   (require-digraph 'vertex_out_degree 2 gr)
 365   (require-vertex-in-graph 'vertex_out_degree v gr)
 366   (length (out-neighbors v gr)))
 367
 368 (defmfun $get_vertex_label (v gr &optional default)
 369   (require-vertex 'get_vertex_label 1 v)
 370   (require-graph-or-digraph 'get_vertex_label 2 gr)
 371   (require-vertex-in-graph 'vertex_label v gr)
 372   (or (get-vertex-label v gr) default))
 373
 374 (defun get-vertex-label (v gr)
 375   (gethash v  (if (graph-p gr)
 376                   (graph-vertex-labels gr)
 377                   (digraph-vertex-labels gr))))
 378
 379 (defmfun $get_unique_vertex_by_label (l gr)
 380   (unless (stringp l) (merror (intl:gettext "get_unique_vertex_by_label: first argument must be a string; found ~M") l))
 381   (require-graph-or-digraph 'get_unique_vertex_by_label 2 gr)
 382   (get-unique-vertex-by-label l gr))
 383
 384 (defun get-unique-vertex-by-label (l gr)
 385   (let ((vv (get-all-vertices-by-label l gr)))
 386     (cond
 387       ((null vv) nil)
 388       ((= (length vv) 1) (first vv))
 389       (t (merror (intl:gettext "get_unique_vertex_by_label: two or more vertices have the same label ~:M") l)))))
 390
 391 (defun get-all-vertices-by-label (l gr)
 392   (let (vv)
 393     (maphash (lambda (v l1) (when (string= l1 l) (push v vv)))
 394              (if (graph-p gr) (graph-vertex-labels gr) (digraph-vertex-labels gr)))
 395     (sort vv '<)))
 396
 397 (defmfun $get_all_vertices_by_label (l gr)
 398   (unless (stringp l) (merror (intl:gettext "get_all_vertices_by_label: first argument must be a string; found ~M") l))
 399   (require-graph-or-digraph 'get_all_vertices_by_label 2 gr)
 400   (cons '(mlist) (get-all-vertices-by-label l gr)))
 401
 402 (defmfun $clear_vertex_label (v gr)
 403   (require-vertex 'clear_vertex_label 1 v)
 404   (require-graph-or-digraph 'clear_vertex_label 2 gr)
 405   (require-vertex-in-graph 'clear_label v gr)
 406   (clear-vertex-label v gr))
 407
 408 (defun clear-vertex-label (v gr)
 409   (remhash v (if (graph-p gr)
 410                  (graph-vertex-labels gr)
 411                  (digraph-vertex-labels gr)))
 412   '$done)
 413
 414 (defmfun $set_vertex_label (v l gr)
 415   (require-vertex 'set_vertex_label 1 v)
 416   (require-graph-or-digraph 'set_vertex_label 3 gr)
 417   (require-vertex-in-graph 'set_label v gr)
 418   (set-vertex-label v l gr))
 419
 420 (defun set-vertex-label (v l gr)
 421   (setf (gethash v (if (graph-p gr)
 422                        (graph-vertex-labels gr)
 423                        (digraph-vertex-labels gr)))
 424         l)
 425   '$done)
 426
 427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 428 ;;;
 429 ;;; edge operations
 430 ;;;
 431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 432
 433 (defun require-medge (m ar e)
 434   (cond
 435     ((not (and ($listp e) (eql 2 ($length e))))
 436      ($error "Argument" ar "to" m "is not an edge (0)."))
 437     (t (let ((u ($first e)) (v ($second e)))
 438          (unless (and (integerp u) (integerp v))
 439            ($error "Argument" ar "to" m "is not an edge (1)."))
 440          (when (eq u v)
 441            ($error "Argument" ar "to" m "is not an edge (2)."))))))
 442
 443 (defun require-edge-in-graph (m e gr)
 444   (unless (is-edge-in-graph e gr)
 445     ($error m ": edge not in graph.")))
 446
 447 (defun m-edge-to-l-edge (e)
 448   (let ((uv (cdr e)))
 449     (list (apply #'min uv) (apply #'max uv))))
 450
 451 (defun m-edge-to-l-dedge (e)
 452   (let ((uv (cdr e)))
 453     (list (first uv) (second uv))))
 454
 455 (defun l-edge-to-m-edge (e)
 456   `((mlist simp) ,@e))
 457
 458 (defmfun $is_edge_in_graph (e gr)
 459   (require-medge 'is_edge_in_graph 1 e)
 460   (require-graph-or-digraph 'is_edge_in_graph 2 gr)
 461   (if (graph-p gr)
 462       (is-edge-in-graph (m-edge-to-l-edge e) gr)
 463       (is-edge-in-graph (m-edge-to-l-dedge e) gr)))
 464
 465 (defun is-edge-in-graph (e gr)
 466   (if (graph-p gr)
 467       (not (null (member (second e) (neighbors (first e) gr))))
 468       (not (null (member (second e) (out-neighbors (first e) gr)))) ))
 469
 470 (defmfun $add_edge (e gr)
 471   (require-medge 'add_edge 1 e)
 472   (require-graph-or-digraph 'add_edge 2 gr)
 473   (let* ((e1 (if (graph-p gr)
 474                  (m-edge-to-l-edge e)
 475                  (m-edge-to-l-dedge e)))
 476          (u (first e1)) (v (second e1)))
 477     (cond
 478       ((not (and (is-vertex-in-graph u gr) (is-vertex-in-graph v gr)))
 479        ($error "add_edge: end vertices are not in graph!"))
 480       ((eq u v)
 481        ($error "add_edge: end vertices are equal!"))
 482       ((is-edge-in-graph e1 gr)
 483        ($error "add_edge: edge already in graph!")))
 484     (add-edge e1 gr)))
 485
 486 (defmfun $add_edges (el gr)
 487   (require-graph-or-digraph 'add_edges 2 gr)
 488   (if (not ($listp el))
 489       ($error "Argument 1 to add_edges is not a list!")
 490       (dolist (e (cdr el))
 491         (require-medge 'add_edges 1 e)
 492         ($add_edge e gr)))
 493   '$done)
 494
 495 (defun add-edge (e gr)
 496   (let ((u (first e)) (v (second e)))
 497     (if (graph-p gr)
 498         (progn
 499           (push v (gethash u (graph-neighbors gr)))
 500           (push u (gethash v (graph-neighbors gr)))
 501           (push e (graph-edges gr))
 502           (incf (graph-size gr)))
 503         (progn
 504           (push v (gethash u (digraph-out-neighbors gr)))
 505           (push u (gethash v (digraph-in-neighbors gr)))
 506           (push e (digraph-edges gr))
 507           (incf (digraph-size gr))))
 508     '$done))
 509
 510 (defun add-edges (elist gr)
 511   (dolist (e elist)
 512     (add-edge e gr)))
 513
 514 (defmfun $edges (gr)
 515   (require-graph-or-digraph 'edges 1 gr)
 516   (let ((e (mapcar #'(lambda (u) `((mlist simp) ,@(copy-list u)))
 517                    (edges gr))))
 518     `((mlist simp) ,@e)))
 519
 520 (defun edges (gr)
 521   (if (graph-p gr)
 522       (graph-edges gr)
 523       (digraph-edges gr)))
 524
 525 (defmfun $remove_edge (e gr)
 526   (require-medge 'remove_edge 1 e)
 527   (require-graph-or-digraph 'remove_edge 2 gr)
 528   (unless ($is_edge_in_graph e gr)
 529     ($error "remove_edge: edge" e "is not in graph."))
 530   (remove-edge (if (graph-p gr)
 531                    (m-edge-to-l-edge e)
 532                    (m-edge-to-l-dedge e))
 533                gr))
 534
 535 (defmfun $remove_edges (el gr)
 536   (require-graph-or-digraph 'remove_edges 2 gr)
 537   (unless ($listp el)
 538     ($error "Argument 1 to remove_edges is not a list."))
 539   (dolist (e (cdr el))
 540     ($remove_edge e gr))
 541   '$done)
 542
 543 (defun remove-edge (e gr)
 544   (let ((u (first e)) (v (second e)))
 545     (if (graph-p gr)
 546         (progn
 547           (setf (gethash u (graph-neighbors gr))
 548                 (remove v (gethash u (graph-neighbors gr)) :count 1))
 549           (setf (gethash v (graph-neighbors gr))
 550                 (remove u (gethash v (graph-neighbors gr)) :count 1))
 551           (clear-edge-weight e gr)
 552           (decf (graph-size gr))
 553           (setf (graph-edges gr)
 554                 (remove `(,u ,v) (graph-edges gr) :test #'equal :count 1)))
 555         (progn
 556           (setf (gethash u (digraph-out-neighbors gr))
 557                 (remove v (gethash u (digraph-out-neighbors gr)) :count 1))
 558           (setf (gethash v (digraph-in-neighbors gr))
 559                 (remove u (gethash v (digraph-in-neighbors gr)) :count 1))
 560           (clear-edge-weight e gr)
 561           (decf (digraph-size gr))
 562           (setf (digraph-edges gr)
 563                 (remove `(,u ,v) (digraph-edges gr) :test #'equal :count 1))))
 564     '$done))
 565
 566 (defmfun $contract_edge (e gr)
 567   (require-medge 'contract_edge 1 e)
 568   (require-graph 'contract_edge 2 gr)
 569   (let* ((e1 (m-edge-to-l-edge e)) (u (first e1)) (v (second e1)))
 570     (dolist (x (neighbors v gr))
 571       (unless (= x u)
 572         (let ((e2 (list (min x u) (max x u))))
 573           (unless (is-edge-in-graph e2 gr)
 574             (add-edge e2 gr)))))
 575     (remove-vertex v gr))
 576   '$done)
 577
 578 (defmfun $contract_edges (el gr)
 579   (require-graph-or-digraph 'contract_edges 2 gr)
 580   (unless ($listp el)
 581     ($error "Argument 1 to contract_edges is not a list."))
 582   (dolist (e (cdr el))
 583     ($contract_edge e gr))
 584   '$done)
 585
 586 (defmfun $get_edge_weight (e gr &optional default not-present)
 587   (require-medge 'get_edge_weight 1 e)
 588   (require-graph-or-digraph 'get_edge_weight 2 gr)
 589   (unless ($is_edge_in_graph e gr)
 590     (if (null not-present)
 591         ($error "get_edge_weight: edge not in graph")
 592         (return-from $get_edge_weight not-present)))
 593   (let ((w (if (graph-p gr)
 594                (get-edge-weight (m-edge-to-l-edge e) gr)
 595                (get-edge-weight (m-edge-to-l-dedge e) gr))))
 596     (or w default 1)))
 597
 598 (defun get-edge-weight (e gr)
 599   (let* ((edge-weights
 600           (if (graph-p gr)
 601               (graph-edge-weights gr)
 602               (digraph-edge-weights gr))))
 603     (gethash e edge-weights)))
 604
 605 (defmfun $clear_edge_weight (e gr)
 606   (require-medge 'clear_edge_weight 1 e)
 607   (require-graph-or-digraph 'clear_edge_weight 2 gr)
 608   (unless ($is_edge_in_graph e gr)
 609     ($error "clear_edge_weight: edge not in graph"))
 610   (if (graph-p gr)
 611       (clear-edge-weight (m-edge-to-l-edge e) gr)
 612       (clear-edge-weight (m-edge-to-l-dedge e) gr)))
 613
 614 (defun clear-edge-weight (e gr)
 615   (let*
 616       ((edge-weights
 617         (if (graph-p gr)
 618             (graph-edge-weights gr)
 619             (digraph-edge-weights gr))))
 620     (remhash e edge-weights)
 621     '$done))
 622
 623 (defmfun $set_edge_weight (e w gr)
 624   (require-medge 'set_edge_weight 1 e)
 625   (require-graph-or-digraph 'set_edge_weight 3 gr)
 626   (unless ($is_edge_in_graph e gr)
 627     ($error "set_edge_weight: edge not in graph"))
 628   (if (graph-p gr)
 629       (set-edge-weight (m-edge-to-l-edge e) w gr)
 630       (set-edge-weight (m-edge-to-l-dedge e) w gr)))
 631
 632 (defun set-edge-weight (e w gr)
 633   (let*
 634       ((edge-weights
 635         (if (graph-p gr)
 636             (graph-edge-weights gr)
 637             (digraph-edge-weights gr))))
 638     (setf (gethash e edge-weights) w)
 639     '$done))
 640
 641 (defmfun $connect_vertices (sources sinks gr)
 642   (require-graph 'connect_vertices 3 gr)
 643   (if ($listp sources)
 644       (setq sources (cdr sources))
 645       (setq sources `(,sources)))
 646   (if ($listp sinks)
 647       (setq sinks (cdr sinks))
 648       (setq sinks `(,sinks)))
 649   (dolist (u sources)
 650     (dolist (v sinks)
 651       ($add_edge `((mlist simp) ,u ,v) gr)))
 652   '$done)
 653
 654 (defmfun $subdivide_edge (e gr)
 655   (require-graph 'subdivide_edge 2 gr)
 656   (require-edge-in-graph 'subdivide_edge (m-edge-to-l-edge e) gr)
 657   (let ((new-vertex (1+ (apply #'max (vertices gr))))
 658         (x ($first e))
 659         (y ($second e)))
 660     ($remove_edge (cons '(mlist simp) (list x y)) gr)
 661     ($add_vertex new-vertex gr)
 662     ($add_edge (cons '(mlist simp) (list x new-vertex)) gr)
 663     ($add_edge (cons '(mlist simp) (list y new-vertex)) gr))
 664   '$done)
 665
 666 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 667 ;;
 668 ;; implementation of a set using hash tables
 669 ;;
 670 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 671
 672 (defstruct ht-set
 673   (content (make-hash-table)))
 674
 675 (defun new-set (&rest initial-content)
 676   (let ((set (make-ht-set)))
 677     (dolist (obj initial-content)
 678       (set-add obj set))
 679     set))
 680
 681 (defun set-member (obj set)
 682   (gethash obj (ht-set-content set)))
 683
 684 (defun set-add (obj set)
 685   (setf (gethash obj (ht-set-content set)) t))
 686
 687 (defun set-remove (obj set)
 688   (remhash obj (ht-set-content set)))
 689
 690 (defun set-emptyp (set)
 691   (= 0 (hash-table-count (ht-set-content set))))
 692
 693 (defun set-elements (set)
 694   (let (elts)
 695     (maphash #'(lambda (key val)
 696                  (declare (ignore val))
 697                  (push key elts))
 698              (ht-set-content set))
 699     elts))
 700
 701
 702 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 703 ;;;
 704 ;;; graph definitions
 705 ;;;
 706 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 707
 708 (defmfun $empty_graph (n)
 709   (let ((gr (make-graph)))
 710     (dotimes (i n)
 711       (add-vertex i gr))
 712     gr))
 713
 714 (defmfun $empty_digraph (n)
 715   (let ((gr (make-digraph)))
 716     (dotimes (i n)
 717       (add-vertex i gr))
 718     gr))
 719
 720 (defmfun $create_graph (v_list e_list &optional dir)
 721   (let ((directed nil))
 722     ;; check if the graph is a directed graph
 723     (cond ((atom dir)
 724            (when dir (setq directed t)))
 725           ((and (eq (caar dir) 'mequal)
 726                 (eq (cadr dir) '$directed)
 727                 (eq (caddr dir) t))
 728            (setq directed t)))
 729     (unless (or (integerp v_list) ($listp v_list))
 730       ($error "Argument 1 to create_graph is not a list."))
 731     (unless ($listp e_list)
 732       ($error "Argument 2 to create_graph is not a list."))
 733     (let ((gr (if directed (make-digraph) (make-graph))))
 734       (if (integerp v_list)
 735           (dotimes (v v_list)
 736             ($add_vertex v gr))
 737           (dolist (v (reverse (cdr v_list)))
 738             (if ($listp v)
 739                 (progn
 740                   ($add_vertex ($first v) gr)
 741                   ($set_vertex_label ($first v) ($second v) gr))
 742                 ($add_vertex v gr))))
 743       (dolist (e (cdr e_list))
 744         (if ($listp ($first e))
 745             (progn
 746               ($add_edge ($first e) gr)
 747               ($set_edge_weight ($first e) ($second e) gr))
 748             ($add_edge e gr)))
 749       gr)))
 750
 751 (defmfun $cycle_graph (n)
 752   (let ((g ($empty_graph n)) pos)
 753     (dotimes (i (1- n))
 754       (add-edge (list i (1+ i)) g))
 755     (add-edge (list 0 (1- n)) g)
 756     (dotimes (i n)
 757       (setq pos (cons `((mlist simp) ,i
 758                         ((mlist simp) ,($cos (* i 2 pi (/ n))) ,($sin (* i 2 pi (/ n)))))
 759                       pos)))
 760     ($set_positions (cons '(mlist simp) pos) g)
 761     g))
 762
 763 (defmfun $cycle_digraph (n)
 764   (let ((g ($empty_digraph n)))
 765     (dotimes (i (1- n))
 766       (add-edge (list i (1+ i)) g))
 767     (add-edge (list (1- n) 0) g)
 768     g))
 769
 770 (defmfun $path_graph (n)
 771   (let ((g ($empty_graph n)) pos)
 772     (dotimes (i (1- n))
 773       (add-edge (list i (1+ i)) g))
 774     (dotimes (i n)
 775       (setq pos (cons `((mlist simp) ,i
 776                         ((mlist simp) ,i 0))
 777                       pos)))
 778     ($set_positions (cons '(mlist simp) pos) g)
 779     g))
 780
 781 (defmfun $path_digraph (n)
 782   (let ((g ($empty_digraph n)))
 783     (dotimes (i (1- n))
 784       (add-edge (list i (1+ i)) g))
 785     g))
 786
 787 (defmfun $petersen_graph (&optional n d)
 788   (if (null d)
 789       (setq n 5 d 2)
 790       (unless (and (integerp n) (integerp d))
 791         ($error "Arguments to petersen_graph are not integers!")))
 792   (let ((g ($empty_graph (* 2 n)))
 793         (positions ()))
 794     (dotimes (i n)
 795       (add-edge `(,i ,(+ n i)) g)
 796       (when (or (/= n (* 2 d))
 797                 (< i d))
 798         (let* ((u (+ i n)) (v (+ (mod (+ i d) n) n))
 799                (e1 (min v u)) (e2 (max v u)))
 800         (add-edge `(,e1 ,e2) g)))
 801       (let* ((u (mod (1+ i) n)) (e1 (min u i)) (e2 (max u i)))
 802         (add-edge `(,e1 ,e2) g)))
 803     (dotimes (i n)
 804       (push `((mlist simp) ,i ((mlist simp)
 805                                ,($sin (/ (* 2 i pi) n))
 806                                ,($cos (/ (* 2 i pi) n))))
 807             positions)
 808       (push `((mlist simp) ,(+ n i) ((mlist simp)
 809                                      ,(* 0.66 ($sin (/ (* 2 i pi) n)))
 810                                      ,(* 0.66 ($cos (/ (* 2 i pi) n)))))
 811             positions))
 812     (setf (graph-vertex-positions g) (cons '(mlist simp) positions))
 813     g))
 814
 815 (defmfun $complement_graph (gr)
 816   (require-graph 'complement_graph 1 gr)
 817   (let*
 818       ((co (make-graph))
 819        (vrt (vertices gr)))
 820     (dolist (v vrt)
 821       (add-vertex v co))
 822     (dolist (u vrt)
 823       (dolist (v vrt)
 824         (when (and (< u v) (not (is-edge-in-graph `(,u ,v) gr)))
 825           (add-edge `(,u ,v) co))))
 826     (setf (graph-vertex-positions co) (graph-vertex-positions gr))
 827     co))
 828
 829 (defmfun $complete_graph (n)
 830   (if (not (and (integerp n ) (>= n 0)))
 831       ($error "Argument 1 to complete_graph is not a positive integer"))
 832   (let ((g ($empty_graph n))
 833         (pos))
 834     (dotimes (i n)
 835       (do
 836        ((j (1+ i) (1+ j)))
 837        ((= j n))
 838         (add-edge `(,i ,j) g)))
 839     (dotimes (i n)
 840       (push `((mlist simp) ,i ((mlist simp)
 841                                ,($cos (/ (* 2 i pi) n))
 842                                ,($sin (/ (* 2 i pi) n))))
 843             pos))
 844     (setf (graph-vertex-positions g) (cons '(mlist simp) pos))
 845     g))
 846
 847 (defmfun $from_adjacency_matrix (m)
 848   (if (not ($matrixp m))
 849       ($error "Argument 1 to from_adjacency_matrix is not a matrix"))
 850   (if (not (= ($length m) ($length ($first m))))
 851       ($error "Argument 1 to from_adjacency_matrix is not a square matrix"))
 852   (let* ((n ($length m)) (g ($empty_graph n)))
 853     (dotimes (i n)
 854       (do ((j (1+ i) (1+ j)))
 855           ((= j n))
 856         (if (not (= 0 (nth (1+ i) (nth (1+ j) m))))
 857             (add-edge `(,i ,j) g))))
 858     g))
 859
 860 (defmfun $graph_union (&rest gr-list)
 861   (cond
 862     ((= 0 (length gr-list))
 863      ($empty_graph 0))
 864     ((= 1 (length gr-list))
 865      (first gr-list))
 866     ((= 2 (length gr-list))
 867      (graph-union (first gr-list) (second gr-list)))
 868     (t
 869      (graph-union (first gr-list) (apply #'$graph_union (rest gr-list))))))
 870
 871 (defun graph-union (g1 g2)
 872   (require-graph 'graph_union 1 g1)
 873   (require-graph 'graph_union 2 g2)
 874   (let ((g (make-graph)) (n (1+ (apply #'max (graph-vertices g1)))))
 875     (dolist (v (graph-vertices g1))
 876       (add-vertex v g))
 877     (dolist (e (graph-edges g1))
 878       (add-edge e g))
 879     (dolist (v (graph-vertices g2))
 880       (add-vertex (+ n v) g))
 881     (dolist (e (graph-edges g2))
 882       (add-edge (list (+ n (first e)) (+ n (second e))) g))
 883     g))
 884
 885 (defmfun $graph_join (g1 g2)
 886   (require-graph 'graph_join 1 g1)
 887   (require-graph 'graph_join 2 g2)
 888   (let ((g (make-graph)) (n (1+ (apply #'max (graph-vertices g1)))))
 889     (dolist (v (graph-vertices g1))
 890       (add-vertex v g))
 891     (dolist (e (graph-edges g1))
 892       (add-edge e g))
 893     (dolist (v (graph-vertices g2))
 894       (add-vertex (+ n v) g))
 895     (dolist (e (graph-edges g2))
 896       (add-edge (list (+ n (first e)) (+ n (second e))) g))
 897     (dolist (v (graph-vertices g1))
 898       (dolist (u (graph-vertices g2))
 899         (add-edge (list v (+ n u)) g)))
 900     g))
 901
 902 (defun get-canonical-names (l)
 903   (let ((names ()) (i 0))
 904     (dolist (v l)
 905       (push `(,v . ,i) names)
 906       (setq i (1+ i)))
 907     names))
 908
 909 (defmfun $graph_product (&rest gr-list)
 910   (cond
 911     ((= 0 (length gr-list))
 912      ($empty_graph 0))
 913     ((= 1 (length gr-list))
 914      (first gr-list))
 915     ((= 2 (length gr-list))
 916      (graph-product (first gr-list) (second gr-list)))
 917     (t
 918      (graph-product (first gr-list) (apply #'$graph_product (rest gr-list))))))
 919
 920 (defun graph-product (g1 g2)
 921   (require-graph 'graph_product 1 g1)
 922   (require-graph 'graph_product 2 g2)
 923   (let*
 924       ((names1 (get-canonical-names (graph-vertices g1)))
 925        (names2 (get-canonical-names (graph-vertices g2)))
 926        (size1 (graph-order g1))
 927        (size2 (graph-order g2))
 928        (size (* size1 size2))
 929        (g ($empty_graph size)))
 930     (dolist (e (graph-edges g1))
 931       (dolist (v (graph-vertices g2))
 932         (let*
 933             ((v1 (cdr (assoc (first e) names1)))
 934              (v2 (cdr (assoc (second e) names1)))
 935              (u (cdr (assoc v names2)))
 936              (f (list (+ (* u size1) v1) (+ (* u size1) v2)))
 937              (f (list (apply #'min f) (apply #'max f))))
 938           (add-edge f g))))
 939     (dolist (e (graph-edges g2))
 940       (dolist (v (graph-vertices g1))
 941         (let*
 942             ((v1 (cdr (assoc (first e) names2)))
 943              (v2 (cdr (assoc (second e) names2)))
 944              (u (cdr (assoc v names1)))
 945              (f (list (+ (* v1 size1) u) (+ (* v2 size1) u)))
 946              (f (list (apply #'min f) (apply #'max f))))
 947           (add-edge f g))))
 948     g))
 949
 950 (defmfun $line_graph (gr)
 951   (require-graph 'line_graph 1 gr)
 952   (let* ((edge-list
 953           (get-canonical-names (graph-edges gr))) (n (graph-size gr))
 954          (g ($empty_graph n)))
 955     (dotimes (i n)
 956       (do ((j (1+ i) (1+ j)))
 957           ((= j n))
 958         (let ((e (car (rassoc i edge-list))) (f (car (rassoc j edge-list))))
 959           (if
 960            (or (member (first e) f) (member (second e) f))
 961            (add-edge `(,i ,j) g)))))
 962     g))
 963
 964 (defmfun $random_graph (n p)
 965   (if (not (integerp n))
 966       ($error "Argument 1 to random_graph is not an integer"))
 967   (if (not (floatp ($float p)))
 968       ($error "Argument 2 to random_graph is not a float"))
 969   (let ((g ($empty_graph n))
 970         (p ($float p)))
 971     (dotimes (i n)
 972       (do ((j (1+ i) (1+ j)))
 973           ((= j n))
 974         (if (< (random 1.0) p)
 975             (add-edge `(,i ,j) g))))
 976     g))
 977
 978 (defmfun $random_graph1 (n m)
 979   #+sbcl (declare (notinline $random_graph1))
 980   (unless (integerp n)
 981     ($error "Argument 1 to random_graph is not an integer"))
 982   (unless (integerp m)
 983     ($error "Argument 2 to random_graph is not an integer"))
 984   (when (< (* n (1- n)) (* 2 m))
 985     ($error "random_graph1: no such graph"))
 986   (when (< (* n (1- n)) (* 4 m))
 987     (return-from $random_graph1
 988       ($complement_graph ($random_graph1 n (- (/ (* n (1- n)) 2) m)))))
 989   (let ((g ($empty_graph n)))
 990     (do ((i 0)) ((= i m))
 991       (let ((u (random n)) (v (random n)))
 992         (unless (= u v)
 993           (let ((e (list (min u v) (max u v))))
 994             (unless (is-edge-in-graph e g)
 995               (setq i (1+ i))
 996               (add-edge e g))))))
 997     g))
 998
 999 (defmfun $random_bipartite_graph (a b p)
1000   (unless (integerp a)
1001     ($error "Argument 1 to random graph is not an integer"))
1002   (unless (integerp b)
1003     ($error "Argument b to random graph is not an integer"))
1004   (let ((g ($empty_graph (+ a b))))
1005     (dotimes (x a)
1006       (dotimes (y b)
1007         (when (< (random 1.0) p)
1008           (add-edge (list x (+ a y)) g))))
1009     g))
1010
1011 (defmfun $random_digraph (n p)
1012   (unless (integerp n)
1013     ($error "Argument 1 to random_digraph is not an integer"))
1014   (unless (floatp ($float p))
1015     ($error "Argument 2 to random_digraph is not a float"))
1016   (let ((g ($empty_digraph n))
1017         (p ($float p)))
1018     (dotimes (i n)
1019       (dotimes (j n)
1020         (when (and (not (= i j)) (< (random 1.0) p))
1021           (add-edge `(,i ,j) g))))
1022     g))
1023
1024 (defmfun $random_tournament (n)
1025   (unless (and (integerp n) (>= n 0))
1026     ($error "Argument 1 to random_tournament is not a positive integer"))
1027   (let ((g ($empty_digraph n)))
1028     (dotimes (i n)
1029       (do ((j (1+ i) (1+ j)))
1030           ((= j n))
1031         (if (and (not (= i j)) (< (random 1.0) 0.5))
1032             (add-edge `(,i ,j) g)
1033             (add-edge `(,j ,i) g))))
1034     g))
1035
1036 (defmfun $random_tree (n)
1037   (unless (and  (integerp n) (>= n 0))
1038     ($error "Argument 1 to random_tree is not a positive integer"))
1039   (let*
1040       ((tr ($empty_graph n))
1041        (vrt (remove 0 (graph-vertices tr) :count 1))
1042        (tree-vrt '(0)))
1043     (dotimes (i (1- n))
1044       (let
1045           ((u (nth (random (length vrt)) vrt))
1046            (v (nth (random (length tree-vrt)) tree-vrt)))
1047         (setq vrt (remove u vrt :count 1))
1048         (push u tree-vrt)
1049         (add-edge (list (min u v) (max u v)) tr)))
1050     tr))
1051
1052 (defmfun $underlying_graph (gr)
1053   (require-digraph 'underlying_graph 1 gr)
1054   (let ((g (make-graph)))
1055     (dolist (v (vertices gr))
1056       (add-vertex v g))
1057     (dolist (e (digraph-edges gr))
1058       (let ((u (first e)) (v (second e)))
1059         (let ((e1 (list (apply #'min e) (apply #'max e))))
1060           (when (not (is-edge-in-graph e1 g))
1061             (add-edge `(,u ,v) g)))))
1062     g))
1063
1064 (defmfun $induced_subgraph (vl gr)
1065   (require-graph 2 'induced_subgraph gr)
1066   (unless ($listp vl)
1067     ($error "First argument to induced_subgraph is not a list."))
1068   (let
1069       ((v_l (cdr vl))
1070        (g (make-graph)))
1071     (dolist (v v_l)
1072       (when (not (is-vertex-in-graph v gr))
1073         ($error
1074          "induced_subgraph: second argument is not a list of vertices"))
1075       (add-vertex v g)
1076       (let ((l (get-vertex-label v gr)))
1077         (when l
1078           (set-vertex-label v l g))))
1079     (dolist (e (graph-edges gr))
1080       (let ((u (first e)) (v (second e)))
1081         (when (and (member u v_l) (member v v_l))
1082           (add-edge e g))))
1083     g))
1084
1085 (defmfun $wheel_graph (n)
1086   (unless (and (integerp n) (>= n 3))
1087     ($error "wheel_graph: first argument is no an integer greater than 3"))
1088   (let ((g ($cycle_graph n))
1089         (positions ()))
1090     (add-vertex n g)
1091     (dotimes (i n)
1092       (add-edge `(,i ,n) g))
1093     (dotimes (i n)
1094       (push `((mlist simp) ,i ((mlist simp)
1095                                ,($sin (/ (* 2 i pi) n))
1096                                ,($cos (/ (* 2 i pi) n))))
1097             positions))
1098     (push `((mlist simp) ,n ((mlist simp) 0 0)) positions)
1099     ($set_positions (cons '(mlist simp) positions) g)
1100     g))
1101
1102 (defmfun $circulant_graph (n l)
1103   (unless (and (integerp n) (> n 0))
1104     ($error "Argument 1 to circulant_graph is not a positive integer."))
1105   (unless ($listp l)
1106     ($error "Argument 2 to circulant_graph is not a list."))
1107   (let ((g ($empty_graph n))
1108         (positions ()))
1109     (dolist (d (cdr l))
1110       (unless (and (integerp d) (> d 0))
1111         ($error
1112          "Argument 2 to circulant graph is no a list of positive integers"))
1113       (dotimes (i n)
1114         (let ((e `(,i ,(mod (+ i d) n))))
1115           (setq e (list (apply #'min e) (apply #'max e)))
1116           (add-edge e g))))
1117     (dotimes (i n)
1118       (push `((mlist simp) ,i ((mlist simp)
1119                                ,($sin (m// (m* 2.0 i pi) n))
1120                                ,($cos (m// (m* 2.0 i pi) n))))
1121             positions))
1122     ($set_positions (cons '(mlist simp) positions) g)
1123     g))
1124
1125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1126 ;;;
1127 ;;; graph properties
1128 ;;;
1129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1130
1131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1132 ;;;
1133 ;;; Connected components
1134 ;;;
1135
1136 (defmfun $connected_components (gr)
1137   (require-graph 'connected_components 1 gr)
1138   (when (= 0 (graph-order gr))
1139     (return-from $connected_components '((mlist simp))))
1140   (let ((components ()) (visited (make-hash-table)))
1141     (loop for v in (vertices gr) do
1142          (unless (gethash v visited)
1143            (let ((c ()) (active ()))
1144              (push v active)
1145              (loop while active do
1146                   (let ((x (pop active)))
1147                     (push x c)
1148                     (setf (gethash x visited) t)
1149                     (dolist (u (neighbors x gr))
1150                       (unless (or (gethash u visited) (member u active))
1151                         (push u active)))))
1152              (push `((mlist simp) ,@c) components))))
1153     `((mlist simp) ,@components)))
1154
1155 (defmfun $is_connected (gr)
1156   (require-graph 'is_connected 1 gr)
1157   (<= ($length ($connected_components gr)) 1))
1158
1159 (defmfun $is_tree (gr)
1160   (require-graph 'is_tree 1 gr)
1161   (and ($is_connected gr) (= (graph-order gr) (1+ (graph-size gr)))))
1162
1163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1164 ;;;
1165 ;;; Reachable vertices
1166 ;;;
1167
1168
1169 (defmfun $reachable_vertices (v gr)
1170   (require-graph-or-digraph 'reachable_vertices 2 gr)
1171   (require-vertex 'reachable_vertices 1 v)
1172   (require-vertex-in-graph 'reachable_vertices v gr)
1173   (when (= 0 (if (graph-p gr) (graph-order gr) (digraph-order gr)))
1174     (return-from $reachable_vertices '((mlist simp))))
1175   (let ((component ()) (visited (make-hash-table)))
1176     (unless (gethash v visited)
1177       (let ((active ()))
1178         (push v active)
1179         (loop while active do
1180              (let ((x (pop active)))
1181                (push x component)
1182                (setf (gethash x visited) t)
1183                (dolist (u (if (graph-p gr) (neighbors x gr) (out-neighbors x gr)))
1184                  (unless (or (gethash u visited) (member u active))
1185                    (push u active)))))))
1186     `((mlist simp) ,@component)))
1187
1188 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1189 ;;;
1190 ;;; Adjacency matrix and Laplacian matrix
1191 ;;;
1192
1193 (defmfun $adjacency_matrix (gr)
1194   (require-graph-or-digraph 'adjacency_matrix 1 gr)
1195   (let* ((n (if (graph-p gr) (graph-order gr) (digraph-order gr)))
1196          (m ($zeromatrix n n))
1197          (names (get-canonical-names (vertices gr))))
1198     (dolist (e (edges gr))
1199       (setf (nth (1+ (cdr (assoc (first e) names)))
1200                  (nth (1+ (cdr (assoc (second e) names))) m)) 1)
1201       (when (graph-p gr)
1202         (setf (nth (1+ (cdr (assoc (second e) names)))
1203                    (nth (1+ (cdr (assoc (first e) names))) m)) 1)))
1204     m))
1205
1206 (defmfun $laplacian_matrix (gr)
1207   (require-graph 'laplacian_matrix 1 gr)
1208   (let ((m ($zeromatrix (graph-order gr) (graph-order gr)))
1209         (names (get-canonical-names (vertices gr))))
1210     (dolist (v (graph-vertices gr))
1211       (setf (nth (1+ (cdr (assoc v names)))
1212                  (nth (1+ (cdr (assoc v names))) m))
1213             (length (neighbors v gr))))
1214     (dolist (e (graph-edges gr))
1215       (setf (nth (1+ (cdr (assoc (first e) names)))
1216                  (nth (1+ (cdr (assoc (second e) names))) m)) -1)
1217       (setf (nth (1+ (cdr (assoc (second e) names)))
1218                  (nth (1+ (cdr (assoc (first e) names))) m)) -1))
1219     m))
1220
1221 (defmfun $graph_charpoly (gr x)
1222   (require-graph 'graph_charpoly 1 gr)
1223   (let (($ratmx t))
1224     ($charpoly ($adjacency_matrix gr) x)))
1225
1226 (defmfun $graph_eigenvalues (gr)
1227   (require-graph 'graph_eigenvalues 1 gr)
1228   (let (($ratmx t))
1229     (mfuncall '$eigenvalues ($adjacency_matrix gr))))
1230
1231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1232 ;;;
1233 ;;; girth, odd_girth
1234 ;;;
1235
1236 (defmfun $girth (gr)
1237   (require-graph 'girth 1 gr)
1238   (girth gr nil))
1239
1240 (defmfun $odd_girth (gr)
1241   (require-graph 'odd_girth 1 gr)
1242   (girth gr t))
1243
1244 (defun girth (gr odd)
1245   (let ((girth (1+ (graph-order gr))))
1246     (dolist (v (graph-vertices gr))
1247       (let
1248           ((visited (new-set v))
1249            (active (new-set v))
1250            (next)
1251            (depth 1))
1252         (do ()
1253             ((or (set-emptyp active)
1254                  (> (* 2 depth) girth)
1255                  (<= girth 3)))
1256           (setq next (new-set))
1257           (dolist (u (set-elements active))
1258             (dolist (w (neighbors u gr))
1259               (if (not (set-member w visited))
1260                   (progn
1261                     (set-add w visited)
1262                     (set-add w next))
1263                   (progn
1264                     (if (set-member w active)
1265                         (setq girth (- (* 2 depth) 1)))
1266                     (if (and (not odd) (set-member w next))
1267                         (setq girth (min girth (* 2 depth))))))))
1268           (setq active next)
1269           (setq depth (1+ depth)))))
1270     (if (> girth (graph-order gr))
1271         '$inf
1272         girth)))
1273
1274 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1275 ;;;
1276 ;;; diameter, radius
1277 ;;;
1278
1279 (defmfun $vertex_eccentricity (v gr)
1280   (require-graph 'vertex_eccentricity 1 gr)
1281   (require-vertex-in-graph 'vertex_eccentricity v gr)
1282   (let ((ecc (eccentricity (list v) gr)))
1283     (gethash v ecc)))
1284
1285 (defun eccentricity (v_list gr)
1286   (unless ($is_connected gr)
1287     ($error "eccentricity: graph is not connected."))
1288   (let ((ecc (make-hash-table)))
1289     (dolist (v v_list)
1290       (let
1291           ((visited (new-set v))
1292            (active (new-set v))
1293            (next)
1294            (depth -1))
1295         (do ()
1296             ((set-emptyp active))
1297           (setq next (new-set))
1298           (dolist (u (set-elements active))
1299             (dolist (w (neighbors u gr))
1300               (when (not (set-member w visited))
1301                 (set-add w visited)
1302                 (set-add w next))))
1303           (setq active next)
1304           (setq depth (1+ depth)))
1305         (setf (gethash v ecc) depth)))
1306       ecc))
1307
1308 (defmfun $diameter (gr)
1309   (require-graph 'diameter 1 gr)
1310   (let ((ecc (eccentricity (vertices gr) gr))
1311         (diameter 0))
1312     (maphash #'(lambda (key val)
1313                  (declare (ignore key))
1314                  (when (> val diameter)
1315                    (setq diameter val)))
1316              ecc)
1317     diameter))
1318
1319 (defmfun $radius (gr)
1320   (require-graph 'radius 1 gr)
1321   (let ((ecc (eccentricity (vertices gr) gr))
1322         (radius ($graph_order gr)))
1323     (maphash #'(lambda (key val)
1324                  (declare (ignore key))
1325                  (when (< val radius)
1326                    (setq radius val)))
1327              ecc)
1328     radius))
1329
1330 (defmfun $graph_center (gr)
1331   (require-graph 'graph_center 1 gr)
1332   (let ((ecc (eccentricity (vertices gr) gr))
1333         (per ())
1334         (radius ($graph_order gr)))
1335     (maphash #'(lambda (key val)
1336                  (declare (ignore key))
1337                  (when (< val radius)
1338                    (setq radius val)))
1339              ecc)
1340     (maphash #'(lambda (key val)
1341                  (when (= val radius)
1342                    (push key per)))
1343              ecc)
1344     `((mlist simp) ,@per)))
1345
1346 (defmfun $graph_periphery (gr)
1347   (require-graph 'graph_periphery 1 gr)
1348   (let ((ecc (eccentricity (vertices gr) gr))
1349         (center ())
1350         (diameter 0))
1351     (maphash #'(lambda (key val)
1352                  (declare (ignore key))
1353                  (when (> val diameter)
1354                    (setq diameter val)))
1355              ecc)
1356     (maphash #'(lambda (key val)
1357                  (when (= val diameter)
1358                    (push key center)))
1359              ecc)
1360     `((mlist simp) ,@center)))
1361
1362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1363 ;;;
1364 ;;; bipartition
1365 ;;;
1366
1367 (defmfun $bipartition (gr)
1368   (require-graph 'bipartition 1 gr)
1369   (when (= (graph-order gr) 0)
1370     (return-from $bipartition `((mlist simp) ((mlist simp)) ((mlist simp)))))
1371   (let ((components (cdr ($connected_components gr))) (A ()) (B ()))
1372     (dolist (c components)
1373       (let ((partition (bi-partition (first (cdr c)) gr)))
1374         (if (null partition)
1375             (return-from $bipartition `((mlist simp)))
1376             (progn
1377               (setq A (append A (first partition)))
1378               (setq B (append B (second partition)))))))
1379     `((mlist simp) ((mlist simp) ,@A) ((mlist simp) ,@B))))
1380
1381 (defun bi-partition (v gr)
1382   (let
1383       ((A ())
1384        (B ())
1385        (visited (new-set))
1386        (active `(,v))
1387        (colors (make-hash-table)))
1388     (setf (gethash v colors) 1)
1389     (do ()
1390         ((null active))
1391       (let*
1392           ((w (pop active))
1393            (wc (gethash w colors)))
1394         (set-add w visited)
1395         (if (= wc 1)
1396             (push w A)
1397             (push w B))
1398         (dolist (u (neighbors w gr))
1399           (if (set-member u visited)
1400               (when (= (gethash u colors) wc)
1401                 (return-from bi-partition ()))
1402               (unless (member u active)
1403                 (push u active)
1404                 (setf (gethash u colors) (- 1 wc)))))))
1405     `(,A ,B)))
1406
1407 (defmfun $is_bipartite (gr)
1408   (require-graph 'is_bipartite 1 gr)
1409   (> ($length ($bipartition gr)) 1))
1410
1411 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1412 ;;;
1413 ;;; 2-connectivity
1414 ;;;
1415
1416 (defmfun $biconnected_components (gr)
1417   (require-graph 'biconnected_components 1 gr)
1418   (if (= 0 (graph-order gr))
1419       `((mlist simp))
1420       (let
1421           ((bicomp `((mlist simp)))
1422            (comp (cdr ($connected_components gr))))
1423         (dolist (c comp)
1424           (if (= ($length c) 1)
1425               (setq bicomp ($append bicomp `((mlist simp) ,c)))
1426               (setq bicomp ($append bicomp (bicomponents ($first c) gr)))))
1427         bicomp)))
1428
1429 (defmfun $is_biconnected (gr)
1430   (require-graph 'is_biconnected 1 gr)
1431   (eql ($length ($biconnected_components gr)) 1))
1432
1433 (defvar *dfs-bicomp-depth* 0)
1434 (defvar *dfs-bicomp-num* ())
1435 (defvar *dfs-bicomp-low-pt* ())
1436 (defvar *dfs-bicomp-edges* ())
1437 (defvar *bicomponents* ())
1438
1439 (defun bicomponents (v gr)
1440   (let ((bicomp ()))
1441     (setq *dfs-bicomp-depth* 0)
1442     (setq *dfs-bicomp-num* (make-hash-table))
1443     (setq *dfs-bicomp-low-pt* (make-hash-table))
1444     (setq *dfs-bicomp-edges* (make-hash-table))
1445     (setq *bicomponents* ())
1446     (dolist (v (graph-vertices gr))
1447       (setf (gethash v *dfs-bicomp-num*) 0))
1448     (dfs-bicomponents gr v)
1449     (dolist (c *bicomponents*)
1450       (let ((curr-comp ()))
1451         (dolist (e c)
1452           (let ((u (first e)) (v (second e)))
1453             (unless (member u curr-comp)
1454               (push u curr-comp))
1455             (unless (member v curr-comp)
1456               (push v curr-comp))))
1457         (setq bicomp (cons `((mlist simp) ,@(sort curr-comp #'<)) bicomp))))
1458     `((mlist simp) ,@bicomp)))
1459
1460 (defun dfs-bicomponents (gr w)
1461   (setq *dfs-bicomp-depth* (1+ *dfs-bicomp-depth*))
1462   (setf (gethash w *dfs-bicomp-num*) *dfs-bicomp-depth*)
1463   (setf (gethash w *dfs-bicomp-low-pt*) *dfs-bicomp-depth*)
1464   (dolist (u (neighbors w gr))
1465     (when (< (gethash u *dfs-bicomp-num*) (gethash w *dfs-bicomp-num*))
1466       (push `(,w ,u) *dfs-bicomp-edges*))
1467     (if (= 0 (gethash u *dfs-bicomp-num*))
1468         (progn
1469           (dfs-bicomponents gr u)
1470           (if (>= (gethash u *dfs-bicomp-low-pt*)
1471                   (gethash w *dfs-bicomp-num*))
1472               (let ((e 0) (comp ()))
1473                 (do ()
1474                     ((equal e `(,w ,u)))
1475                   (setq e (pop *dfs-bicomp-edges*))
1476                   (push e comp))
1477                 (push comp *bicomponents*))
1478               (setf (gethash w *dfs-bicomp-low-pt*)
1479                     (min (gethash w *dfs-bicomp-low-pt*)
1480                          (gethash u *dfs-bicomp-low-pt*)))))
1481         (setf (gethash w *dfs-bicomp-low-pt*)
1482               (min (gethash w *dfs-bicomp-low-pt*)
1483                    (gethash u *dfs-bicomp-num*))))))
1484
1485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1486 ;;;
1487 ;;; strong connectivity
1488 ;;;
1489
1490 (defvar *scon-low* nil)
1491 (defvar *scon-dfn* nil)
1492 (defvar *scon-comp* nil)
1493 (defvar *scon-st*  nil)
1494 (defvar *scon-vrt* nil)
1495 (defvar *scon-depth* 0)
1496
1497 (defmfun $strong_components (gr)
1498   (require-digraph 'strong_components 1 gr)
1499   (if (= 0 (digraph-order gr))
1500       `((mlist simp))
1501       (let ((res))
1502         (setq *scon-low* (make-hash-table))
1503         (setq *scon-dfn* (make-hash-table))
1504         (setq *scon-comp* ())
1505         (setq *scon-st* ())
1506         (setq *scon-vrt* (digraph-vertices gr))
1507         (loop while (not (null *scon-vrt*)) do
1508               (setq *scon-depth* 0)
1509               (dfs-strong-components gr (first *scon-vrt*))
1510               (dolist (c *scon-comp*)
1511                 (push c res))
1512               (setq *scon-comp* ()))
1513         `((mlist simp) ,@res))))
1514
1515 (defmfun $is_sconnected (gr)
1516   (require-digraph 'strong_components 1 gr)
1517   (eql ($length ($strong_components gr)) 1))
1518
1519 (defun dfs-strong-components (gr v)
1520   (incf *scon-depth*)
1521   (setf (gethash v *scon-dfn*) *scon-depth*)
1522   (setf (gethash v *scon-low*) *scon-depth*)
1523   (setf *scon-vrt* (remove v *scon-vrt* :count 1))
1524   (push v *scon-st*)
1525   (dolist (u (neighbors v gr))
1526     (if (gethash u *scon-dfn*)
1527         (when (and (< (gethash u *scon-dfn*) (gethash v *scon-dfn*))
1528                    (member u *scon-st*))
1529           (setf (gethash v *scon-low*)
1530                 (min (gethash v *scon-low*)
1531                      (gethash u *scon-dfn*))))
1532         (progn
1533           (dfs-strong-components gr u)
1534           (setf (gethash v *scon-low*)
1535                 (min (gethash v *scon-low*)
1536                      (gethash u *scon-low*))))))
1537   (when (= (gethash v *scon-low*) (gethash v *scon-dfn*))
1538     (let ((x (pop *scon-st*))
1539           (comp ()))
1540       (loop while (not (= x v)) do
1541            (push x comp)
1542            (setq x (pop *scon-st*)))
1543       (push x comp)
1544       (setq *scon-comp* (cons `((mlist simp) ,@comp) *scon-comp*)))))
1545
1546 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1547 ;;;
1548 ;;; topological sorting
1549 ;;;
1550
1551 (defmfun $topological_sort (dag)
1552   (require-digraph 'topological_sort 1 dag)
1553   (let ((in-degrees (make-hash-table))
1554         (q ())
1555         (n ($graph_size dag))
1556         (s ()))
1557     (dolist (v (vertices dag))
1558       (setf (gethash v in-degrees) 0))
1559     (dolist (e (edges dag))
1560       (incf (gethash (second e) in-degrees)))
1561     (dolist (v (vertices dag))
1562       (when (= (gethash v in-degrees) 0)
1563         (push v q)))
1564     (loop while (> (length q) 0) do
1565          (let ((v (pop q)))
1566            (push v s)
1567            (dolist (u (out-neighbors v dag))
1568              (decf (gethash u in-degrees))
1569              (decf n)
1570              (when (= (gethash u in-degrees) 0)
1571                (push u q)))))
1572     (if (= n 0)
1573         `((mlist simp) ,@(reverse s))
1574         '((mlist simp)))))
1575
1576 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1577 ;;;
1578 ;;; max_flow (augmenting paths)
1579 ;;;
1580
1581 (defmfun $max_flow (net source sink)
1582   (require-digraph 'max_flow 1 net)
1583   (require-vertex 'max_flow 2 source)
1584   (require-vertex 'max_flow 3 sink)
1585   (require-vertex-in-graph 'max_flow source net)
1586   (require-vertex-in-graph 'max_flow sink net)
1587   (let
1588       ((d (make-hash-table)) (active ()) (lbls (make-hash-table))
1589        (flow (make-hash-table :test #'equal)) (val 0)
1590        ($ratprint nil))
1591     (dolist (e (digraph-edges net))
1592       (setf (gethash e flow) 0))
1593     (dolist (v (digraph-vertices net))
1594       (setf (gethash v d) '$inf))
1595     (setf (gethash source lbls) `(,source -1 $inf))
1596     (push source active)
1597     (do ()
1598         ((null active))
1599       (let ((v (pop active)))
1600         (dolist (w (out-neighbors v net))
1601           (if (and (null (gethash w lbls))
1602                    (mlsp (gethash `(,v ,w) flow)
1603                          (or (get-edge-weight `(,v ,w) net) 1)))
1604               (progn
1605                 (setf (gethash w d)
1606                       (mfuncall '$min
1607                                 (m- (or (get-edge-weight `(,v ,w) net) 1)
1608                                     (gethash `(,v ,w) flow))
1609                                 (gethash v d)))
1610                 (setf (gethash w lbls) `(,v 1 ,(gethash w d)))
1611                       (push w active))))
1612         (dolist (w (in-neighbors v net))
1613           (if (and (null (gethash w lbls))
1614                    (mgrp (gethash `(,w ,v) flow) 0))
1615               (progn
1616                 (setf (gethash w d) (mfuncall '$min
1617                                               (gethash `(,w ,v) flow)
1618                                               (gethash v d)))
1619                 (setf (gethash w lbls) `(,v -1 ,(gethash w d)))
1620                 (push w active))))
1621         (if (gethash sink lbls)
1622             (let ((dd (third (gethash sink lbls))) (w sink))
1623               (setq val (m+ dd val))
1624               (do ()
1625                   ((= w source))
1626                 (let ((v1 (first (gethash w lbls)))
1627                       (vl (second (gethash w lbls))))
1628                   (if (= vl 1)
1629                       (setf (gethash `(,v1 ,w) flow)
1630                             (m+ (gethash `(,v1 ,w) flow) dd))
1631                       (setf (gethash `(,w ,v1) flow)
1632                             (m- (gethash `(,w ,v1) flow) dd)))
1633                   (setq w v1)))
1634               (setq lbls (make-hash-table))
1635               (setf (gethash source lbls) `(,source -1 $inf))
1636               (dolist (v1 (digraph-vertices net))
1637                 (setf (gethash v1 d) '$inf))
1638               (setq active `(,source))))))
1639     (let ((max-flow ()))
1640       (dolist (e (digraph-edges net))
1641         (push `((mlist simp) ((mlist simp) ,@e)
1642                 ,(gethash e flow)) max-flow))
1643       `((mlist simp) ,val ((mlist simp) ,@max-flow)))))
1644
1645 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1646 ;;;
1647 ;;; shortest path
1648 ;;;
1649
1650 (defmfun $shortest_path (u v g)
1651   (require-graph-or-digraph 'shortest_path 3 g)
1652   (require-vertex 'shortest_path 1 u)
1653   (require-vertex 'shortest_path 2 v)
1654   (require-vertex-in-graph 'shortest_path v g)
1655   (require-vertex-in-graph 'shortest_path u g)
1656   (let ((active (make-hash-table)) (visited (make-hash-table)) (previous (make-hash-table)))
1657     (setf (gethash u active) t)
1658     (do ()
1659         ((or (= 0 (hash-table-count active)) (gethash v visited)))
1660       (let ((next (make-hash-table)))
1661         (loop for w being the hash-keys of active do
1662              (setf (gethash w visited) t)
1663              (dolist (x (neighbors w g))
1664                (unless (or (gethash x active) (gethash x visited) (gethash x next))
1665                  (setf (gethash x previous) w)
1666                  (setf (gethash x next) t))))
1667         (setq active next)))
1668     (if (gethash v visited)
1669         (let ((path (list v)))
1670           (do ((x v))
1671               ((= x u))
1672             (setq x (gethash x previous))
1673             (push x path))
1674           `((mlist simp) ,@path))
1675         `((mlist simp)))))
1676
1677 (defmfun $vertex_distance (u v g)
1678   (require-graph-or-digraph 'shortest_path 3 g)
1679   (require-vertex 'shortest_path 1 u)
1680   (require-vertex 'shortest_path 2 v)
1681   (require-vertex-in-graph 'shortest_path v g)
1682   (require-vertex-in-graph 'shortest_path u g)
1683   (let ((d ($length ($shortest_path u v g))))
1684     (if (> d 0)
1685         (1- d)
1686         '$inf)))
1687
1688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1689 ;;;
1690 ;;; minimum spanning tree
1691 ;;;
1692
1693 (defun edge-weight-1 (e gr)
1694   (cond ((gethash e (graph-edge-weights gr)))
1695         (t 1)))
1696
1697 (defun graph-edges-with-weights (gr)
1698   (let ((edges (graph-edges gr)) (edges-with-weights ()))
1699     (dolist (e edges)
1700       (push `(,e ,(edge-weight-1 e gr)) edges-with-weights))
1701     edges-with-weights))
1702
1703 (defun edges-by-weights (gr)
1704   (let ((edges (graph-edges-with-weights gr)))
1705     (sort edges #'(lambda (u v) (mlsp (second u) (second v))))))
1706
1707 (defun in-same-part (u v p)
1708   (let ((up u) (vp v))
1709     (do ()
1710         ((= up (gethash up p)))
1711       (let ((up1 (gethash up p)))
1712         (setf (gethash up p) (gethash up1 p)))
1713       (setq up (gethash up p)))
1714     (do ()
1715         ((= vp (gethash vp p)))
1716       (let ((vp1 (gethash vp p)))
1717         (setf (gethash vp p) (gethash vp1 p)))
1718       (setq vp (gethash vp p)))
1719     (= up vp)))
1720
1721 (defun join-parts (u v p)
1722   (let ((up u) (vp v))
1723     (do ()
1724         ((= up (gethash up p)))
1725       (setq up (gethash up p)))
1726     (do ()
1727         ((= vp (gethash vp p)))
1728       (setq vp (gethash vp p)))
1729     (setf (gethash up p) (gethash vp p))))
1730
1731 (defmfun $minimum_spanning_tree (gr)
1732   (require-graph 'minimum_spanning_tree 1 gr)
1733   (let ((edges (edges-by-weights gr)) (tr (make-graph))
1734         (part (make-hash-table)))
1735     (dolist (v (graph-vertices gr))
1736       (add-vertex v tr)
1737       (setf (gethash v part) v))
1738     (dolist (e edges)
1739       (let ((u (caar e)) (v (cadar e)))
1740         (if (not (in-same-part u v part))
1741             (progn
1742               (add-edge `(,u ,v) tr)
1743               (join-parts u v part)))))
1744     tr))
1745
1746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1747 ;;;
1748 ;;; hamilton cycle
1749 ;;;
1750
1751 (defvar *hamilton-cycle* ())
1752
1753 (defmfun $hamilton_cycle (gr)
1754   (require-graph 'hamilton_cycle 1 gr)
1755   (let (*hamilton-cycle* (*v0* ($first_vertex gr)))
1756     (declare (special *v0*))
1757     (unless ($is_biconnected gr)
1758       (return-from $hamilton_cycle `((mlist simp))))
1759     (hamilton-cycle (list *v0*) gr)
1760     `((mlist simp) ,@(reverse *hamilton-cycle*))))
1761
1762 (defun hamilton-cycle (part gr)
1763   (declare (special *v0*))
1764   (unless *hamilton-cycle*
1765     (if (= (length part) (if (graph-p gr)
1766                              (graph-order gr)
1767                              (digraph-order gr)))
1768         (if (member (car (last part)) (neighbors (first part) gr))
1769             (setq *hamilton-cycle* (append (last part) part))))
1770     (dolist (v (neighbors (car part) gr))
1771       (when (null (member v part))
1772         (if (< (length part) 3)
1773             (hamilton-cycle (cons v part) gr)
1774             (let ((gr1 ($copy_graph gr))
1775                   (in-part (rest (reverse part))))
1776               ($remove_vertices (cons '(mlist simp) in-part) gr1)
1777               (unless (member v (neighbors *v0* gr))
1778                 ($add_edge `((mlist simp) ,v ,*v0*) gr1))
1779               (when ($is_biconnected gr1)
1780                 (hamilton-cycle (cons v part) gr))))))))
1781
1782 (defmfun $hamilton_path (gr)
1783   (require-graph 'hamilton_path 1 gr)
1784   ;; first check if there exists a HC
1785   (let ((hc ($hamilton_cycle gr)))
1786     (when (cdr hc)
1787       (return-from $hamilton_path ($rest hc))))
1788   ;; check with all non-edges
1789   (let ((grc ($complement_graph gr)))
1790     (dolist (v (vertices gr))
1791       (dolist (u (neighbors v grc))
1792         (when (< v u)
1793           (let ((*v0* v)
1794                 (*hamilton-cycle*)
1795                 (part (list u v)))
1796             (declare (special *v0*))
1797             (hamilton-cycle part gr)
1798             (when *hamilton-cycle*
1799               (return-from $hamilton_path (cons '(mlist simp) (rest (reverse *hamilton-cycle*))))))))))
1800   '((mlist simp)))
1801
1802 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1803 ;;;
1804 ;;; maximum clique
1805 ;;;
1806
1807 (defvar *maximum-clique* ())
1808
1809 (defmfun $vertices_by_degree (gr)
1810   (require-graph 'vertices_by_degrees 1 gr)
1811   (cons '(mlist simp) (vertices-by-degrees gr)))
1812
1813 (defun vertices-by-degrees (gr)
1814   (let ((vrt ()))
1815     (dolist (v (vertices gr))
1816       (push `(,v ,(length (neighbors v gr))) vrt))
1817     (setq vrt (sort vrt #'(lambda (u v) (> (second u) (second v)))))
1818     (mapcar #'first vrt)))
1819
1820 (defun greedy-color (gr)
1821   (let ((coloring (make-hash-table))
1822         (available-colors (make-hash-table)) (tmp ()))
1823     (dotimes (i (graph-order gr))
1824       (push i tmp))
1825     (setq tmp (reverse tmp))
1826     (dolist (v (graph-vertices gr))
1827       (setf (gethash v available-colors) (copy-tree tmp)))
1828     (dolist (v (vertices-by-degrees gr))
1829       (let ((c (car (gethash v available-colors))))
1830         (setf (gethash v coloring) c)
1831         (dolist (u (neighbors v gr))
1832           (setf (gethash u available-colors)
1833                 (remove c (gethash u available-colors) :count 1)))))
1834     coloring))
1835
1836 (defmfun $max_clique (gr)
1837   (require-graph 'max_clique 1 gr)
1838   (setq *maximum-clique* ())
1839   (let ((v) (coloring) (h ($copy_graph gr)))
1840     (do () ((or (>= (length *maximum-clique*) (graph-order h))
1841                 (> (length *maximum-clique*) ($first ($max_degree h)))))
1842 ;      (print *maximum-clique*)
1843 ;      (print ($max_degree h))
1844       (setq coloring (greedy-color h))
1845       (setq v ($second ($max_degree h)))
1846       (extend-clique `(,v) (neighbors v h) coloring h)
1847       (remove-vertex v h)))
1848   `((mlist simp) ,@(sort *maximum-clique* #'<)))
1849
1850 (defmfun $min_vertex_cover (gr)
1851   (require-graph 'min_vertex_cover 1 gr)
1852   (let ((bipart ($bipartition gr)))
1853     (if (null (cdr bipart))
1854         (let ((vc)
1855               (mc (cdr ($max_clique ($complement_graph gr)))))
1856           (loop for v in (vertices gr) do
1857                (unless (member v mc)
1858                  (setq vc (cons v vc))))
1859           `((mlist simp) ,@vc))
1860         (maximum-matching-bipartite gr (cadr bipart) (caddr bipart) t))))
1861
1862 (defmfun $max_independent_set (gr)
1863   (require-graph 'max_independent_set 1 gr)
1864   (if ($is_bipartite gr)
1865       (let ((mis)
1866             (vc (cdr ($min_vertex_cover gr))))
1867         (loop for v in (vertices gr) do
1868              (unless (member v vc)
1869                (setq mis (cons v mis))))
1870         `((mlist simp) ,@mis))
1871       ($max_clique ($complement_graph gr))))
1872
1873 (defun extend-clique (clique neigh coloring gr)
1874   (if (= (length neigh) 0)
1875       ;; did we get to a maximal clique
1876       (if (> (length clique) (length *maximum-clique*))
1877           (progn
1878             (setq *maximum-clique* clique)
1879             (return-from extend-clique)))
1880       ;; can we do better?
1881       (let ((colors ()))
1882         (dolist (x neigh)
1883           (if (not (member (gethash x coloring) colors))
1884               (push (gethash x coloring) colors)))
1885         (if (> (+ (length clique) (length colors)) (length *maximum-clique*))
1886             ;; try improving
1887             (do () ((= (length neigh) 0))
1888               (let* ((x (first neigh)) (new-clique (cons x clique))
1889                      (new-neigh ()))
1890                 (dolist (y neigh)
1891                   (if (is-edge-in-graph `(,(min x y) ,(max x y)) gr)
1892                       (push y new-neigh)))
1893                 (extend-clique new-clique new-neigh coloring gr)
1894                 (setq neigh (remove x neigh))))))))
1895
1896 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1897 ;;;
1898 ;;; colorings
1899 ;;;
1900
1901 (defmfun $vertex_coloring (g)
1902   (require-graph 'vertex_coloring 1 g)
1903   (let ((col (dsatur g)) (res ()) (chnumber 0))
1904     (dolist (v (vertices g))
1905       (push `((mlist simp) ,v ,(gethash v col)) res)
1906       (setq chnumber (max chnumber (gethash v col))))
1907     `((mlist simp) ,chnumber ((mlist simp) ,@res))))
1908
1909 (defmfun $chromatic_number (g)
1910   (require-graph 'chromatic_number 1 g)
1911   ($first ($vertex_coloring g)))
1912
1913 (defmfun $edge_coloring (gr)
1914   (require-graph 'edge_coloring 1 gr)
1915   (let* ((edge-list (get-canonical-names (graph-edges gr)))
1916          (n (graph-size gr))
1917          (g ($empty_graph n)))
1918     (dotimes (i n)
1919       (do
1920        ((j (1+ i) (1+ j)))
1921        ((= j n))
1922         (let ((e (car (rassoc i edge-list))) (f (car (rassoc j edge-list))))
1923           (if
1924            (or (member (first e) f) (member (second e) f))
1925            (add-edge `(,i ,j) g)))))
1926     (let ((coloring (dsatur g))
1927           (ch-index -1)
1928           (res ()))
1929       (dotimes (i n)
1930         (push `((mlist simp) ((mlist simp) ,@(car (rassoc i edge-list)))
1931                 ,(gethash i coloring)) res)
1932         (setq ch-index (max ch-index (gethash i coloring))))
1933       `((mlist simp) ,ch-index ((mlist simp) ,@res)))))
1934
1935 (defmfun $chromatic_index (g)
1936   (require-graph 'chromatic_index 1 g)
1937   ($first ($vertex_coloring ($line_graph g))))
1938
1939 (defun dsatur (g)
1940   (when (< (length (vertices g)) 2)
1941     (let ((col (make-hash-table)))
1942       (dolist (v (vertices g))
1943         (setf (gethash v col) 1))
1944       (return-from dsatur col)))
1945   (let* ((x)
1946          (vsize (length (vertices g)))
1947          (opt-chnumber (1+ vsize)) (back nil)
1948          (i 0) (k)
1949          (free-color)
1950          (xindex)
1951          (stop nil)
1952          (clique (greedy-clique g))
1953          (clique-size (length clique))
1954          (start clique-size)
1955          (A (make-array vsize))
1956          (F (make-hash-table))
1957          (f-opt (make-hash-table))
1958          (number-of-used-colors (make-hash-table :test #'equal))
1959          (dsat (make-hash-table))
1960          (uncolored (make-hash-table)))
1961
1962     ;; Prepare data
1963     ;(format t "~%Preparing data")
1964     (dolist (v clique)
1965       (setf (aref A i) v)
1966       (setf (gethash v F) (1+ i))
1967       (setq i (1+ i)))
1968     (dolist (v (vertices g))
1969       (setf (gethash v dsat) 0)
1970       (setf (gethash v uncolored) (length (neighbors v g)))
1971       (if (not (member v clique))
1972           (progn
1973             (setf (aref A i) v)
1974             (setq i (1+ i))
1975             (setf (gethash v F) 0))))
1976     (dolist (v clique)
1977       (dolist (u (neighbors v g))
1978         (decf (gethash u uncolored))
1979         (setf (gethash `(,u ,(gethash v F)) number-of-used-colors) 1)
1980         (incf (gethash u dsat))))
1981
1982     ;(format t "~%Clique size: ~d" (length clique))
1983     ;(format t "~%Clique:      ~d" clique)
1984     (do () (nil)
1985       ;(format t "~%Starting with: ~d (~d)" start (aref A start))
1986       (do ((i start (1+ i))) ((or (= i vsize) stop))
1987
1988         ;; Choose new vertex x
1989         (if back
1990             (progn
1991               (setq xindex start)
1992               (setq x (aref A xindex)))
1993             (let ((mdsat -1) (munc -1))
1994               (do ((j i (1+ j))) ((= j vsize))
1995                 (if (or (> (gethash (aref A j) dsat) mdsat)
1996                         (and (= (gethash (aref A j) dsat) mdsat)
1997                              (> (gethash (aref A j) uncolored) munc)))
1998                     (progn
1999                       (setq x (aref  A j))
2000                       (setq xindex j)
2001                       (setq mdsat (gethash x dsat))
2002                       (setq munc (gethash x uncolored)))))))
2003         ;(format t "~%New vertex: ~d" x)
2004
2005         ;; Choose free color
2006         (setq free-color 0)
2007         (if back
2008             (progn
2009               (setq back nil)
2010               (setq k (1+ (gethash x F))))
2011             (setq k 1))
2012         (do ((j k (1+ j))) ((or (>= j opt-chnumber) (> free-color 0)))
2013           (if (= 0 (gethash `(,x ,j) number-of-used-colors 0))
2014               (setq free-color j)))
2015         ;(format t "~%New color: ~d" free-color)
2016
2017         (if (> free-color 0)
2018             ;; Color vertex x
2019             (progn
2020               (setf (gethash x F) free-color)
2021               ;; Update dsat index
2022               (dolist (u (neighbors x g))
2023                 (incf (gethash `(,u ,free-color) number-of-used-colors 0))
2024                 (if (= 1 (gethash `(,u ,free-color) number-of-used-colors 0))
2025                     (incf (gethash u dsat)))
2026                 (decf (gethash u uncolored)))
2027               ;; Update A
2028               (rotatef (aref A i) (aref A xindex)))
2029             ;; Unable to extend coloring - backtrack
2030             (progn
2031               (setq start (1- i))
2032               (setq stop t)
2033               (setq back t))))
2034
2035       (setq stop nil)
2036       (if back
2037           ;; We have a backtrack step
2038           (progn
2039             (if (< start clique-size)
2040                 (return-from dsatur f-opt))
2041             (setq x (aref A start))
2042             (setq k (gethash x F))
2043             ;; Delete the color of x
2044             (dolist (v (neighbors x g))
2045               (decf (gethash `(,v ,k) number-of-used-colors))
2046               (incf (gethash v uncolored))
2047               (if (= 0 (gethash `(,v ,k) number-of-used-colors))
2048                   (decf (gethash v dsat)))))
2049           ;; We have a coloring!
2050           (progn
2051             ;; Save new optimal coloring
2052             (setq opt-chnumber 0)
2053             (dolist (v (vertices g))
2054               (setf (gethash v f-opt) (gethash v F))
2055               (setq opt-chnumber (max opt-chnumber (gethash v F))))
2056             ;(format t "~%Found new coloring: ~d" opt-chnumber)
2057             ;; Find new start
2058             (setq start -1)
2059             (do ((i 0 (1+ i))) ((> start -1))
2060               (if (= opt-chnumber (gethash (aref A i) f-opt))
2061                   (progn
2062                     (setq start (1- i)))))
2063             (setq back t)
2064             (if (or (< start clique-size)
2065                     (= opt-chnumber clique-size))
2066                 (return-from dsatur f-opt))
2067             ;; Delete colors from start
2068             (do ((i start (1+ i))) ((= i vsize))
2069               (dolist (v (neighbors  (aref A i) g))
2070                 (decf (gethash `(,v ,(gethash (aref A i) F))
2071                                number-of-used-colors))
2072                 (incf (gethash v uncolored))
2073                 (if (= 0 (gethash `(,v ,(gethash (aref A i) F))
2074                                   number-of-used-colors))
2075                     (decf (gethash v dsat)))))
2076             )))))
2077
2078 (defun greedy-clique (g)
2079   (let ((clique ()))
2080     (dolist (v (vertices g))
2081       (let ((tmp-clique (extend-greedy-clique `(,v) (neighbors v g) g)))
2082         (if (> (length tmp-clique) (length clique))
2083             (setq clique tmp-clique))))
2084     clique))
2085
2086 (defun extend-greedy-clique (clique neigh g)
2087   (if (= 0 (length neigh))
2088       (return-from extend-greedy-clique clique))
2089   (if (= 1 (length neigh))
2090       (return-from extend-greedy-clique (cons (car neigh) clique)))
2091   (let ((u nil) (new-neigh ()))
2092     (dolist (v neigh)
2093       (let ((tmp-neigh (copy-tree neigh)))
2094         (dolist (w neigh)
2095           (if (and (not (member w (neighbors v g))))
2096               (setq tmp-neigh (remove w tmp-neigh))))
2097         (if (>= (length tmp-neigh) (length new-neigh))
2098             (progn
2099               (setq u v)
2100               (setq new-neigh tmp-neigh)))))
2101     (if u
2102         (extend-greedy-clique (cons u clique) new-neigh g)
2103         clique)))
2104
2105 ;;;;;;;
2106 ;;
2107 ;; Expose lisp hashtable
2108 ;;
2109 ;;;;;;
2110
2111 (defmfun $hash_table ()
2112   (make-hash-table :test #'equal))
2113
2114 (defmfun $get_hash (elt ht &optional default)
2115   (unless (hash-table-p ht)
2116     ($error "Second argument to `get_hash' is not a hash table!"))
2117   (gethash elt ht default))
2118
2119 (defmfun $set_hash (elt ht value)
2120   (unless (hash-table-p ht)
2121     ($error "Second argument to `set_hash' is not a hash table!"))
2122   (setf (gethash elt ht) value)
2123   value)
2124
2125 (defmfun $hash_table_data (ht)
2126   (unless (hash-table-p ht)
2127     ($error "First argument to `hash_table_info' is not a hash table!"))
2128   (let (res)
2129     (maphash
2130      (lambda (key val)
2131        (setq res (cons `((marrow simp) ,key ,val) res)))
2132      ht)
2133     (cons '(mlist simp) res)))
2134
2135 ;;;;;;;;;;;;;;;;;;;;;;;;;
2136 ;;
2137 ;; This function is needed for draw_graph (get the temporary file to write in)
2138 ;;
2139 ;;;;;;;;;;;;;;;;;;;;;;;;;
2140
2141 (defmfun $temp_filename (file)
2142   (unless (stringp file)
2143     ($error "Argument to `temp_filename' is not a string"))
2144   (plot-temp-file file))
2145
2146 (defmfun $read_string (str)
2147   (unless (stringp str)
2148     ($error "Argument to `read_string' is not a string"))
2149   (let ((num (read-from-string str)))
2150     (if (numberp num) num str)))