share/graphs/demoucron.lisp

   1 ;;;
   2 ;;;  GRAPHS - graph theory package for Maxima
   3 ;;;
   4 ;;;  Copyright (C) 2007 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 (in-package :maxima)
  22
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;;;
  25 ;;; Demoucron planarity test algorithm (a simple quadratic-time
  26 ;;; planarity test algorithm)
  27 ;;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;;
  32 ;; debugging
  33 ;;
  34
  35 (defvar $demoucron_debug nil)
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;;
  39 ;; finds a cycle in g - g should be connected
  40 ;;
  41
  42 (defvar *back-edges*)
  43 (defvar *dfsnum*)
  44 (defvar *dfsnum-curr*)
  45 (defvar *dfs-prev*)
  46
  47 (defun find-cycle (gr)
  48   (let ((*back-edges* ())
  49         (*dfsnum* (make-hash-table))
  50         (*dfs-prev* (make-hash-table))
  51         (*dfsnum-curr* 0)
  52         (v (first (vertices gr)))
  53         (cycle ()))
  54     (setf (gethash v *dfs-prev*) v)
  55     (dfs-find-cycle v gr)
  56     (if (null *back-edges*)
  57         ()
  58         (progn
  59           (let ((u (caar *back-edges*))
  60                 (v (cadar *back-edges*)))
  61             (loop while (not (= u v)) do
  62                  (push u cycle)
  63                  (setq u (gethash u *dfs-prev*)))
  64             (push v cycle))
  65           cycle))))
  66
  67 (defun dfs-find-cycle (v gr)
  68   (setf (gethash v *dfsnum*) *dfsnum-curr*)
  69   (incf *dfsnum-curr*)
  70   (loop for u in (neighbors v gr) do
  71        (if (null (gethash u *dfsnum*))
  72            (progn
  73              (setf (gethash u *dfs-prev*) v)
  74              (dfs-find-cycle u gr))
  75            (when (not (= u (gethash v *dfs-prev*)))
  76              (push (list u v) *back-edges*)))))
  77
  78 (defmfun $find_cycle (gr)
  79   (require-graph 'find_cycle 1 gr)
  80   (let ((cycle (find-cycle gr)))
  81     `((mlist simp) ,@cycle)))
  82
  83 ;;;;;;;;;;;;;;;;;;;;;;;;;
  84 ;;
  85 ;; demoucron algorithm for a biconnected graph gr
  86 ;;
  87
  88 (defvar *h-vertices*)
  89 (defvar *h-edges*)
  90 (defvar *g-vertices*)
  91 (defvar *embedding*)
  92
  93 ;;;;;;;;
  94 ;;
  95 ;; finds facial walks of h (running time o(E(h)))
  96 ;;
  97
  98 (defvar *facial-walks*)
  99
 100 (defun find-facial-walks (edges)
 101   (let ((visited-edges (make-hash-table :test #'equal)))
 102     (loop for e in edges do
 103          (when (null (gethash e visited-edges))
 104            (let* ((u (first e))
 105                   (v (second e))
 106                   (walk (list u))
 107                   (z (gethash (list v u) *embedding*)))
 108              (setf (gethash (list u v) visited-edges) t)
 109              (setq u v)
 110              (setq v z)
 111              (while (not (and (= u (first e))
 112                               (= v (second e))))
 113                (setf (gethash (list u v) visited-edges) t)
 114                (push u walk)
 115                (setq z (gethash (list v u) *embedding*))
 116                (setq u v)
 117                (setq v z))
 118              (push walk *facial-walks*)))) ))
 119
 120 ;;;;;;;;
 121 ;;
 122 ;; finds the bridges in g-h
 123 ;;  - a bridge is a list (vertices-of-the-bridge attachements-of-the-bridge)
 124 ;;
 125
 126 (defvar *bridges*)
 127 (defvar *current-bridge*)
 128 (defvar *current-attachements*)
 129 (defvar *visited-vertices*)
 130
 131 (defun find-bridges (gr)
 132   (setq *bridges* ())
 133   (setq *visited-vertices* (make-hash-table))
 134   (loop for v in *g-vertices* do
 135        (unless (gethash v *visited-vertices*)
 136          (setq *current-bridge* (list v))
 137          (setq *current-attachements* ())
 138          (dfs-find-bridge v gr)
 139          (dolist (v *current-attachements*)
 140            (remhash v *visited-vertices*))
 141          (push (list *current-bridge* *current-attachements*) *bridges*)))
 142   (loop for e in (edges gr) do
 143        (if (and (subsetp e *h-vertices*)
 144                 (null (gethash e *h-edges*)))
 145            (push (list e e) *bridges*))))
 146
 147 (defun dfs-find-bridge (v gr)
 148   (setf (gethash v *visited-vertices*) t)
 149   (loop for u in (neighbors v gr) do
 150        (when (null (gethash u *visited-vertices*))
 151          (push u *current-bridge*)
 152          (if (member u *h-vertices*)
 153              (progn
 154                (setf (gethash u *visited-vertices*) t)
 155                (push u *current-attachements*))
 156              (dfs-find-bridge u gr)))))
 157
 158 ;;;;;;;;
 159 ;;
 160 ;; for each bridge find facial walks in which the bridge can be embedded
 161 ;;  - a bridge is a list (vertices-of-the-bridge attachements-of-the-bridge)
 162 ;;
 163
 164 (defvar *available-faces*)
 165
 166 (defun match-bridges-to-walks ()
 167   (setq *available-faces* (make-hash-table :test #'equal))
 168   (loop for b in *bridges* do
 169        (let ((walks ()))
 170          (loop for w in *facial-walks* do
 171               (if (subsetp (second b) w)
 172                   (push w walks)))
 173          (setf (gethash b *available-faces*) walks))))
 174
 175 ;;;;;;;
 176 ;;
 177 ;; finds a path between attachment vertices in a bridge
 178 ;;
 179
 180 (defvar *dfs-visited*)
 181
 182 (defun find-path (bridge gr)
 183   (when (= (length (first bridge)) 2)
 184     (return-from find-path (first bridge)))
 185   (let ((*dfs-prev* (make-hash-table))
 186         (*dfs-visited* (make-hash-table))
 187         (attachements (second bridge)))
 188     (dfs-find-path (first attachements) (car bridge) gr)
 189     ;; should not happen since graphs are biconnected!
 190     (if (< (length attachements) 2)
 191         (merror "Too few attachements"))
 192     (let ((u (second attachements))
 193           (path ()))
 194       (loop while (not (null (gethash u *dfs-prev*))) do
 195            (push u path)
 196            (setq u (gethash u *dfs-prev*)))
 197       (push u path)
 198       path)))
 199
 200 (defun dfs-find-path (v bridge gr)
 201   (setf (gethash v *dfs-visited*) t)
 202   (loop for u in (neighbors v gr) do
 203        (unless (gethash (list v u) *h-edges*)
 204          (when (and (null (gethash u *dfs-visited*))
 205                     (member u bridge))
 206            (setf (gethash u *dfs-prev*) v)
 207            (unless (member u *h-vertices*)
 208              (dfs-find-path u bridge gr))))))
 209
 210 ;;;;;;;
 211 ;;
 212 ;; ads the path to h and updates the embedding of h
 213 ;;
 214
 215 (defun embedd-path (path face)
 216
 217   ;; add path to h
 218   (let ((inner (cdr path)))
 219     (loop while (not (null (cdr inner))) do
 220          (push (car inner) *h-vertices*)
 221          (setq *g-vertices* (remove (car inner) *g-vertices*))
 222          (setq inner (cdr inner))))
 223   (let ((inner path))
 224     (loop while (not (null (cdr inner))) do
 225          (setf (gethash (list (first inner) (second inner)) *h-edges*) t)
 226          (setf (gethash (list (second inner) (first inner)) *h-edges*) t)
 227          (setq inner (cdr inner))))
 228
 229   ;; add vertices in the inside of the path into the embedding
 230   (let ((path-embedd path))
 231     (loop while (not (null (cddr path-embedd))) do
 232          (let ((u (car path-embedd))
 233                (v (cadr path-embedd))
 234                (z (caddr path-embedd)))
 235            (setf (gethash (list v z) *embedding*) u)
 236            (setf (gethash (list v u) *embedding*) z))
 237          (setq path-embedd (cdr path-embedd))))
 238
 239   ;; add the first vertex into the embedding
 240   (let ((a (first path))
 241         (b (second path))
 242         (rface (reverse face)))
 243     (cond
 244       ((= a (first face))
 245        (let ((c (second face)))
 246          (setf (gethash (list a c) *embedding*) b)
 247          (setf (gethash (list a b) *embedding*) (first rface))))
 248       ((= a (first rface))
 249        (let ((c (second rface)))
 250          (setf (gethash (list a b) *embedding*) c)
 251          (setf (gethash (list a (first face)) *embedding*) b)))
 252       (t
 253        (let ((face face))
 254          (loop while (not (= a (second face))) do
 255               (setq face (cdr face)))
 256          (setf (gethash (list a (third face)) *embedding*) b)
 257          (setf (gethash (list a b) *embedding*) (first face))))))
 258
 259   ;; add the second vertex into the embedding
 260   (setq path (reverse path))
 261   (let ((a (first path))
 262         (b (second path))
 263         (rface (reverse face)))
 264     (cond
 265       ((= a (first face))
 266        (let ((c (second face)))
 267          (setf (gethash (list a c) *embedding*) b)
 268          (setf (gethash (list a b) *embedding*) (first rface))))
 269       ((= a (first rface))
 270        (let ((c (second rface)))
 271          (setf (gethash (list a b) *embedding*) c)
 272          (setf (gethash (list a (first face)) *embedding*) b)))
 273       (t
 274        (let ((face face))
 275          (loop while (not (= a (second face))) do
 276               (setq face (cdr face)))
 277          (setf (gethash (list a (third face)) *embedding*) b)
 278          (setf (gethash (list a b) *embedding*) (first face)))))) )
 279
 280
 281 ;;;;;;;;;;;;;;;;;;;;;;
 282 ;;
 283 ;; this is the demoucron planarity test algorithm
 284 ;; - g should be 2-connected
 285 ;;
 286
 287 (defun demoucron (g return-walks)
 288
 289   (when (> ($graph_size g) (- (* 3 ($graph_order g)) 6))
 290     (return-from demoucron nil))
 291
 292   (let ((*h-vertices*)
 293         (*bridges*)
 294         (*h-edges* (make-hash-table :test #'equal))
 295         (*g-vertices* (cdr ($vertices g)))
 296         (*embedding* (make-hash-table :test #'equal)))
 297
 298     ;; find a cycle - assumes there are no degree one vertices!
 299     (setq *h-vertices* (find-cycle g))
 300     (let ((vrt *h-vertices*))
 301       (loop while (not (null vrt)) do
 302            (setf (gethash (list (first vrt) (second vrt)) *h-edges*) t)
 303            (setf (gethash (list (second vrt) (first vrt)) *h-edges*) t)
 304            (setq vrt (cdr vrt))))
 305     (let ((v (first *h-vertices*))
 306           (u (first (reverse *h-vertices*))))
 307       (setf (gethash (list u v) *h-edges*) t)
 308       (setf (gethash (list v u) *h-edges*) t))
 309     (dolist (v *h-vertices*)
 310       (setq *g-vertices* (remove v *g-vertices*)))
 311
 312     ;; embed h
 313     (let ((cycle *h-vertices*))
 314       (loop while (not (null (cdr cycle))) do
 315            (let ((u (car cycle))
 316                  (v (cadr cycle))
 317                  (z (if (null (caddr cycle)) (car *h-vertices*) (caddr cycle))))
 318              (setf (gethash (list v z) *embedding*) u)
 319              (setf (gethash (list v u) *embedding*) z))
 320            (setq cycle (cdr cycle))))
 321     (let ((u (car (reverse *h-vertices*)))
 322           (v (car *h-vertices*))
 323           (z (cadr *h-vertices*)))
 324       (setf (gethash (list v z) *embedding*) u)
 325       (setf (gethash (list v u) *embedding*) z))
 326
 327     ;; find the bridges in g-h
 328     (find-bridges g)
 329
 330     ;; find facial walks
 331     (setq *facial-walks* ())
 332     (find-facial-walks (list (list (first *h-vertices*) (second *h-vertices*))
 333                              (list (second *h-vertices*) (first *h-vertices*))))
 334
 335     (while (not (null *bridges*))
 336
 337       (when $demoucron_debug
 338         (print "++++++++++++++++++")
 339         (print "--- facial walks:")
 340         (print *facial-walks*)
 341         (print "---      bridges:")
 342         (mapcar #'print *bridges*))
 343       ;; for each bridge find facial walks in which it can be embedded
 344       (match-bridges-to-walks)
 345       ;; select the bridge with the smallest number of available walks
 346       (let ((bridge (first *bridges*))
 347             (path))
 348         ;; find the bridge with the smallest number of possible facial walks
 349         (loop for b in *bridges* do
 350              (when (< (length (gethash b *available-faces*))
 351                       (length (gethash bridge *available-faces*)))
 352                (setq bridge b)))
 353         (when $demoucron_debug
 354           (print "---    embedding:")
 355           (print bridge))
 356         ;; if the bridge can't be embedded, the graph is not planar
 357         (if (= 0 (length (gethash bridge *available-faces* bridge)))
 358             (return-from demoucron nil))
 359         ;; find a path in the bridge
 360         (setq path (find-path bridge g))
 361         ;; embed the path
 362         (embedd-path path (first (gethash bridge *available-faces*)))
 363         (when $demoucron_debug
 364           (print "---         path:")
 365           (print path))
 366         (setq *facial-walks* (remove (first (gethash bridge *available-faces*)) *facial-walks*))
 367         ;; find the facial walks of the embedding of h
 368         (find-facial-walks (list (list (first path) (second path))
 369                                  (list (second path) (first path))))
 370         ;; find new bridges
 371         (find-bridges g)))
 372
 373     ;; if we come here we have embedded the graph into the plane
 374     (if return-walks
 375         (cons '(mlist simp) (mapcar #'(lambda (u) (cons '(mlist simp) u)) *facial-walks*))
 376         t) ))
 377
 378 (defmfun $planar_embedding (gr)
 379   (require-graph 'planar_embedding 1 gr)
 380   (unless ($is_biconnected gr)
 381     ($error "planar_embedding: the graph is not biconnected."))
 382   (demoucron gr t))
 383
 384 (defmfun $is_planar (gr)
 385   (require-graph 'is_planar 1 gr)
 386   (when (< ($graph_order gr) 5)
 387     (return-from $is_planar t))
 388   (when (> ($graph_size gr) (- (* 3 ($graph_order gr)) 6))
 389     (return-from $is_planar nil))
 390   (unless ($is_connected gr)
 391     (return-from $is_planar (is-planar-unconnected gr)))
 392   (when (< ($graph_size gr) ($graph_order gr)) ;; gr is a tree
 393     (return-from $is_planar t))
 394   (let ((bicomponents ($biconnected_components gr)))
 395     (loop for c in (cdr bicomponents) do
 396          (if (> (length c) 4)
 397              (unless (demoucron ($induced_subgraph c gr) nil)
 398                (return-from $is_planar nil))))
 399     t))
 400
 401 (defun is-planar-unconnected (g)
 402   (loop for c in (cdr ($connected_components g)) do
 403        (unless ($is_planar ($induced_subgraph c g))
 404          (return-from is-planar-unconnected nil)))
 405   t)