share/graphs/isomorphism.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
  22 (defmfun $is_isomorphic (gr1 gr2)
  23   (or (= 0 ($graph_order gr1) ($graph_order gr2))
  24       (and (graph-p gr1) (graph-p gr2) (isomorphism-graphs gr1 gr2) t)
  25       (and (digraph-p gr1) (digraph-p gr2) (isomorphism-digraphs gr1 gr2) t)))
  26
  27 (defmfun $isomorphism (gr1 gr2)
  28   (cond ((graph-p gr1)
  29          (if (graph-p gr2)
  30              (let (res
  31                    (iso (isomorphism-graphs gr1 gr2)))
  32                (when iso
  33                  (maphash
  34                   (lambda (key val)
  35                     (setq res (cons `((marrow simp) ,key ,val) res)))
  36                   iso))
  37                (cons '(mlist simp) res))
  38              (merror "Wrong inputs to isomorphism")))
  39         ((digraph-p gr1)
  40          (if (digraph-p gr2)
  41              (let (res
  42                    (iso (isomorphism-digraphs gr1 gr2)))
  43                (when iso
  44                  (maphash
  45                   (lambda (key val)
  46                     (setq res (cons `((marrow simp) ,key ,val) res)))
  47                   iso))
  48                (cons '(mlist simp) res))
  49              (merror "Wrong inputs to isomorphism")))
  50         (t
  51          (merror "Wrong inputs to isomorphism"))))
  52
  53 (defun isomorphism-graphs (gr1 gr2)
  54
  55   ;; check the degree sequences
  56   (let ((gr1-degrees (cdr ($degree_sequence gr1)))
  57         (gr2-degrees (cdr ($degree_sequence gr2))))
  58     (unless (= (length gr1-degrees)
  59                (length gr2-degrees))
  60       (return-from isomorphism-graphs nil))
  61     (loop while (and gr1-degrees gr2-degrees) do
  62          (unless (= (car gr1-degrees)
  63                     (car gr2-degrees))
  64            (return-from isomorphism-graphs nil))
  65          (pop gr1-degrees)
  66          (pop gr2-degrees))
  67     (when (or gr1-degrees gr2-degrees)
  68       (return-from isomorphism-graphs nil)))
  69
  70   (let ((n (graph-order gr1))
  71         (m (graph-size gr1)))
  72     (when (< (* n (1- n)) (* 4 m))
  73       (setq gr1 ($complement_graph gr1))
  74       (setq gr2 ($complement_graph gr2))))
  75
  76   (let ((mapping (make-hash-table))
  77         (m1) (m2) (out1) (out2))
  78     (extend-isomorphism-graphs mapping m1 m2 out1 out2 gr1 gr2)))
  79
  80 (defun extend-isomorphism-graphs (mapping m1 m2 out1 out2 gr1 gr2)
  81   ;; check if we have found an isomorphism
  82   (when (= (length m1) ($graph_order gr1))
  83     (return-from extend-isomorphism-graphs mapping))
  84
  85   ;; try extending the mapping
  86   (let (n-set m)
  87     ;; compute the new candidates for mattching
  88     (cond
  89       (out1
  90        (unless out2
  91          (return-from extend-isomorphism-graphs nil))
  92        (setq n-set out1)
  93        (setq m (apply #'min out2)))
  94       (out2
  95        (return-from extend-isomorphism-graphs nil))
  96       (t
  97        (dolist (v (vertices gr1))
  98          (unless (member v m1)
  99            (push v n-set)))
 100        (let ((m-set))
 101          (dolist (v (vertices gr2))
 102            (unless (member v m2)
 103              (push v m-set)))
 104          (setq m (apply #'min m-set)))))
 105
 106     ;; try extending the mapping
 107     (dolist (n n-set)
 108
 109       ;; we have a pair (n->m)
 110       (let ((ok t))
 111         ;; n and m must have the same degree
 112         (unless (= ($vertex_degree n gr1)
 113                    ($vertex_degree m gr2))
 114           (setq ok nil))
 115         ;; check if adjacencies are preserved
 116         (loop for x in m1 while ok do
 117              (if (member x (neighbors n gr1))
 118                  (unless (member (gethash x mapping)
 119                                  (neighbors m gr2))
 120                    (setq ok nil))
 121                  (when (member (gethash x mapping)
 122                                (neighbors m gr2))
 123                    (setq ok nil))))
 124
 125         (when ok
 126           ;; compute the new state
 127           (let ((out1-prime) (out2-prime)
 128                 (m1-prime (cons n m1))
 129                 (m2-prime (cons m m2)))
 130             ;; compute new out sets
 131             (dolist (v m1-prime)
 132               (dolist (u (neighbors v gr1))
 133                 (unless (or (member u out1-prime)
 134                             (member u m1-prime))
 135                   (push u out1-prime))))
 136             (dolist (v m2-prime)
 137               (dolist (u (neighbors v gr2))
 138                 (unless (or (member u out2-prime)
 139                             (member u m2-prime))
 140                   (push u out2-prime))))
 141
 142             ;; if we are compatible try extending
 143             (when (= (length out1-prime) (length out2-prime))
 144               (setf (gethash n mapping) m)
 145               (let ((extended (extend-isomorphism-graphs mapping
 146                                                          m1-prime m2-prime
 147                                                          out1-prime out2-prime
 148                                                          gr1 gr2)))
 149                 (when extended
 150                   (return-from extend-isomorphism-graphs extended)))
 151               (remhash n mapping)))) ))))
 152
 153 (defun isomorphism-digraphs (gr1 gr2)
 154
 155   ;; check the degree sequences
 156   (let ((indegrees1) (outdegrees1)
 157         (indegrees2) (outdegrees2))
 158     (dolist (v (vertices gr1))
 159       (push ($vertex_in_degree v gr1) indegrees1)
 160       (push ($vertex_out_degree v gr1) outdegrees1))
 161     (dolist (v (vertices gr2))
 162       (push ($vertex_in_degree v gr2) indegrees2)
 163       (push ($vertex_out_degree v gr2) outdegrees2))
 164     (setq indegrees1 (sort indegrees1 #'<))
 165     (setq indegrees2 (sort indegrees2 #'<))
 166     (setq outdegrees1 (sort outdegrees1 #'<))
 167     (setq outdegrees2 (sort outdegrees2 #'<))
 168     (loop while (and indegrees1 indegrees2) do
 169          (unless (and (= (car indegrees1) (car indegrees2))
 170                       (= (car outdegrees1) (car outdegrees2)))
 171            (return-from isomorphism-digraphs nil))
 172          (setq indegrees1 (cdr indegrees1))
 173          (setq indegrees2 (cdr indegrees2))
 174          (setq outdegrees1 (cdr outdegrees1))
 175          (setq outdegrees2 (cdr outdegrees2)))
 176     (when (or indegrees1 indegrees2)
 177       (return-from isomorphism-digraphs nil)))
 178
 179   (let ((mapping (make-hash-table))
 180         (m1) (m2) (out1) (out2) (in1) (in2))
 181     (extend-isomorphism-digraphs mapping m1 m2 out1 out2 in1 in2 gr1 gr2)))
 182
 183 (defun extend-isomorphism-digraphs (mapping m1 m2 out1 out2 in1 in2 gr1 gr2)
 184   ;; check if we have found an isomorphism
 185   (when (= (length m1) ($graph_order gr1))
 186     (return-from extend-isomorphism-digraphs mapping))
 187
 188   ;; try extending the mapping
 189   (let (n-set m)
 190     ;; compute the new candidates for mattching
 191     (cond
 192       (out1
 193        (unless out2
 194          (return-from extend-isomorphism-digraphs nil))
 195        (setq n-set out1)
 196        (setq m (apply #'min out2)))
 197       (out2
 198        (return-from extend-isomorphism-digraphs nil))
 199       (in1
 200        (unless in2
 201          (return-from extend-isomorphism-digraphs nil))
 202        (setq n-set in1)
 203        (setq m (apply #'min in2)))
 204       (t
 205        (dolist (v (vertices gr1))
 206          (unless (member v m1)
 207            (push v n-set)))
 208        (let ((m-set))
 209          (dolist (v (vertices gr2))
 210            (unless (member v m2)
 211              (push v m-set)))
 212          (setq m (apply #'min m-set)))))
 213
 214     ;; try extending the mapping
 215     (dolist (n n-set)
 216
 217       ;; we have a pair (n->m)
 218       (let ((ok t))
 219         ;; n and m must have the same degree
 220         (unless (and (= ($vertex_in_degree n gr1)
 221                         ($vertex_in_degree m gr2))
 222                      (= ($vertex_out_degree n gr1)
 223                         ($vertex_out_degree m gr2)))
 224           (setq ok nil))
 225         ;; check if adjacencies are preserved
 226         (loop for x in m1 while ok do
 227              (if (member x (out-neighbors n gr1))
 228                  (unless (member (gethash x mapping)
 229                                  (out-neighbors m gr2))
 230                    (setq ok nil))
 231                  (when (member (gethash x mapping)
 232                                (out-neighbors m gr2))
 233                    (setq ok nil)))
 234              (if (member x (out-neighbors n gr1))
 235                  (unless (member (gethash x mapping)
 236                                  (out-neighbors m gr2))
 237                    (setq ok nil))
 238                  (when (member (gethash x mapping)
 239                                (out-neighbors m gr2))
 240                    (setq ok nil))))
 241
 242         (when ok
 243           ;; compute the new state
 244           (let ((out1-prime) (out2-prime)
 245                 (in1-prime) (in2-prime)
 246                 (m1-prime (cons n m1))
 247                 (m2-prime (cons m m2)))
 248             ;; compute new out sets
 249             (dolist (v m1-prime)
 250               (dolist (u (in-neighbors v gr1))
 251                 (unless (or (member u in1-prime)
 252                             (member u m1-prime))
 253                   (push u in1-prime)))
 254               (dolist (u (out-neighbors v gr1))
 255                 (unless (or (member u out1-prime)
 256                             (member u m1-prime))
 257                   (push u out1-prime))))
 258             (dolist (v m2-prime)
 259               (dolist (u (in-neighbors v gr2))
 260                 (unless (or (member u in2-prime)
 261                             (member u m2-prime))
 262                   (push u in2-prime)))
 263               (dolist (u (out-neighbors v gr2))
 264                 (unless (or (member u out2-prime)
 265                             (member u m2-prime))
 266                   (push u out2-prime))))
 267
 268             ;; if we are compatible try extending
 269             (when (and (= (length out1-prime) (length out2-prime))
 270                        (= (length in1-prime) (length in2-prime)))
 271               (setf (gethash n mapping) m)
 272               (let ((extended (extend-isomorphism-digraphs mapping
 273                                                          m1-prime m2-prime
 274                                                          out1-prime out2-prime
 275                                                          in1-prime in2-prime
 276                                                          gr1 gr2)))
 277                 (when extended
 278                   (return-from extend-isomorphism-digraphs extended)))
 279               (remhash n mapping)))) ))))