share/graphs/graph6.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 ;; This file provides read/write support for the graph6 format and
  26 ;; read support for the sparse6 format. The description of the formats
  27 ;; is here
  28 ;;   http://cs.anu.edu.au/~bdm/data/formats.txt
  29 ;;
  30 ;; There are sites which provide large collections of graphs in these
  31 ;; two formats:
  32 ;;   http://cs.anu.edu.au/~bdm/data/graphs.html
  33 ;;   http://people.csse.uwa.edu.au/gordon/data.html
  34 ;;
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;;
  39 ;; helper functions
  40 ;;
  41
  42 (defun get-n (n)
  43   (if (< n 63)
  44       (list (+ n 63))
  45       (list 126
  46             (+ 63 (boole boole-and 63 (ash n -12)))
  47             (+ 63 (boole boole-and 63 (ash n -6)))
  48             (+ 63 (boole boole-and 63 n)))))
  49
  50 (defun get-r (n)
  51   (let ((val ()))
  52     (loop while (> n 0) do
  53          (setq val (cons (+ 63 (boole boole-and n 63)) val))
  54          (setq n (ash n -6)))
  55     val))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;;
  59 ;; encode to graph6 string
  60 ;;
  61
  62 (defmfun $graph6_encode (gr)
  63   (require-graph 'graph6_decode 1 gr)
  64   (graph6-string gr))
  65
  66 (defun graph6-string (gr)
  67   (let ((n ($graph_order gr))
  68         (names (get-canonical-names (vertices gr)))
  69         (e-val))
  70
  71     ;; encode edges
  72     (setq e-val 1)
  73     (loop for i from 1 to (1- n) do
  74          (loop for j from 0 to (1- i) do
  75               (let ((u (car (rassoc i names)))
  76                     (v (car (rassoc j names))))
  77                 (setq e-val (ash e-val 1))
  78                 (if (is-edge-in-graph (list (min u v) (max u v)) gr)
  79                     (incf e-val)))))
  80
  81     ;; add zeros to the right
  82     (let ((n1 (mod (/ (* n (1- n)) 2) 6)))
  83       (unless (= n1 0)
  84         (setq e-val (ash e-val (- 6 n1)))))
  85
  86     ;; change bits to string
  87     (format nil "~{~c~}" (mapcar #'code-char
  88                                  (append (get-n n) (cdr (get-r e-val))))) ))
  89
  90 (defmfun $graph6_export (graphs fl)
  91   (unless (stringp fl)
  92     (merror "`graph6_export': second argument is not a string."))
  93   (unless ($listp graphs)
  94     (merror "`graph6_export': first argument is not a list."))
  95   (with-open-file (stream fl :direction :output :if-exists :supersede)
  96     (dolist (g (cdr graphs))
  97       (format stream "~a~%" ($graph6_encode g))))
  98   'done)
  99
 100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 101 ;;
 102 ;; decode from graph6 string
 103 ;;
 104
 105 (defmfun $graph6_decode (str)
 106   ;; get a lisp string
 107   (unless (stringp str)
 108     (merror "`graph6_decode': argument is not a string."))
 109
 110   ;; read bits from string
 111   (if (and (> (length str) 10)
 112            (string= ">>graph6<<" (subseq str 0 10)))
 113       (setq str (subseq str 10)))
 114
 115   ;; check if it is actually sparse6
 116   (when (string= ":" (subseq str 0 1))
 117     (merror "`graph6_decode': wrong format."))
 118
 119   ;; read the data
 120   (let ((n) (g) (e-bits) (e-val 0)
 121         (bits (mapcar #'char-code (coerce str 'list))))
 122
 123     (if (< (car bits) 126)
 124         (progn
 125           (setq n (- (car bits) 63))
 126           (setq e-bits (cdr bits)))
 127         (progn
 128           (setq bits (cdr bits))
 129           (setq n (+ (ash (- (car bits) 63) 12)
 130                      (ash (- (cadr bits) 63) 6)
 131                      (- (caddr bits) 63)))
 132           (setq e-bits (cdddr bits))))
 133
 134     (dolist (v e-bits)
 135       (setq e-val (ash e-val 6))
 136       (incf e-val (- v 63)))
 137
 138     ;; remove trailing zeros
 139     (let ((n1 (mod (/ (* n (1- n)) 2) 6)))
 140       (unless (= n1 0)
 141         (setq e-val (ash e-val (- n1 6)))))
 142
 143     ;; construct graph
 144     (setq g ($empty_graph n))
 145     (loop for i from (1- n) downto 0 do
 146          (loop for j from (1- i) downto 0 do
 147               (if (> (boole boole-and e-val 1) 0)
 148                   (add-edge (list j i) g))
 149               (setq e-val (ash e-val -1))))
 150     g))
 151
 152 (defmfun $graph6_import (fl)
 153   (unless (stringp fl)
 154     (merror "`graph6_import': argument is not a string."))
 155   (with-open-file (stream fl)
 156     (let ((lst ()))
 157       (do ((line (read-line stream nil 'eof)
 158                  (read-line stream nil 'eof)))
 159           ((eq line 'eof))
 160         (setq lst (cons ($graph6_decode line) lst)))
 161       `((mlist simp) ,@lst))))
 162
 163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 164 ;;
 165 ;; decode from sparse6 string
 166 ;;
 167
 168 (defmfun $sparse6_decode (str)
 169   ;; get a lisp string
 170   (unless (stringp str)
 171     (merror "`sparse6_decode': argument is not a string."))
 172
 173   ;; read bits from string
 174   (if (and (> (length str) 11)
 175            (string= ">>sparse6<<" (subseq str 0 11)))
 176       (setq str (subseq str 11)))
 177
 178   ;; the first character must be ':' and it is ignored
 179   (unless (string= ":" (subseq str 0 1))
 180     (merror "`sparse6_decode': wrong format."))
 181   (setq str (subseq str 1))
 182
 183   ;; read the data
 184   (let ((n) (g) (e-bits) (e-val 0) (k 0)
 185         (bits (mapcar #'char-code (coerce str 'list))))
 186
 187     (if (< (car bits) 126)
 188         (progn
 189           (setq n (- (car bits) 63))
 190           (setq e-bits (cdr bits)))
 191         (progn
 192           (setq bits (cdr bits))
 193           (setq n (+ (ash (- (car bits) 63) 12)
 194                      (ash (- (cadr bits) 63) 6)
 195                      (- (caddr bits) 63)))
 196           (setq e-bits (cdddr bits))))
 197
 198     (dolist (v e-bits)
 199       (setq e-val (ash e-val 6))
 200       (incf e-val (- v 63)))
 201
 202     ;; find k
 203     (setq k (integer-length (1- n)))
 204
 205     ;; construct g
 206     (setq g ($empty_graph n))
 207     (let ((v 0) (bi) (xi) (i (1- (integer-length e-val))))
 208
 209       (loop while (>= i k) do
 210            (setq bi (if (logbitp i e-val) 1 0))
 211            (decf i)
 212            (setq xi 0)
 213            (loop for l from 0 to (1- k) do
 214                 (setq xi (ash xi 1))
 215                 (when (logbitp i e-val)
 216                     (incf xi))
 217                 (decf i))
 218            (when (= bi 1)
 219              (incf v))
 220            (if (> xi v)
 221                (setq v xi)
 222                (unless (>= v n)
 223                  ($add_edge `((mlist simp) ,xi ,v) g)))
 224            (when (>= v n)
 225              (setq i 0))))
 226     g))
 227
 228 (defmfun $sparse6_import (fl)
 229   (unless (stringp fl)
 230     (merror "`sparse6_import': argument is not a string."))
 231   (with-open-file (stream fl)
 232     (let ((lst ()))
 233       (do ((line (read-line stream nil 'eof)
 234                  (read-line stream nil 'eof)))
 235           ((eq line 'eof))
 236         (setq lst (cons ($sparse6_decode line) lst)))
 237       `((mlist simp) ,@lst))))
 238
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 ;;
 241 ;; encode to sparse6 string
 242 ;;
 243
 244 (defmfun $sparse6_encode (gr)
 245   (require-graph 'sparse_encode 1 gr)
 246   (sparse6-string gr))
 247
 248 (defun sparse6-string (gr)
 249   (let* ((vrt (reverse (vertices gr)))
 250          (n ($graph_order gr))
 251          (k (integer-length (1- n)))
 252          (names (get-canonical-names vrt))
 253          (edges (mapcar #'(lambda (u) (list (cdr (assoc (first u) names))
 254                                             (cdr (assoc (second u) names))))
 255                         (edges gr)))
 256          (e-val 0)
 257          (v 0))
 258
 259     ;; Sort the edges
 260     (setq edges (sort edges
 261                       #'(lambda (u v) (or (< (second u) (second v))
 262                                           (and (= (second u) (second v))
 263                                                (< (first u) (first v)))))))
 264     (dolist (e edges)
 265       (let ((x (first e))
 266             (y (second e)))
 267
 268         (if (= y v)
 269             (setq e-val (+ (ash e-val (1+ k)) x))
 270             (progn
 271               (setq e-val (1+ (ash e-val 1)))
 272               (incf v)
 273               (if (= y v)
 274                   (setq e-val (+ (ash e-val k) x))
 275                   (progn
 276                     (setq e-val (+ (ash e-val k) y))
 277                     (setq v y)
 278                     (setq e-val (+ (ash e-val (1+ k)) x))))))))
 279
 280     (unless (= (mod (integer-length e-val) 6) 0)
 281       (let ((n1 (mod (integer-length e-val) 6)))
 282         (setq e-val (1- (ash (1+ e-val) (- 6 n1))))))
 283
 284     (format nil ":~{~c~}" (mapcar #'code-char
 285                                  (append (get-n n) (get-r e-val)))) ))
 286
 287 (defmfun $sparse6_export (graphs fl)
 288   (unless (stringp fl)
 289     (merror "`sparse6_export': second argument is not a string."))
 290   (unless ($listp graphs)
 291     (merror "`sparse6_export': first argument is not a list."))
 292   (with-open-file (stream fl :direction :output :if-exists :supersede)
 293     (dolist (g (cdr graphs))
 294       (format stream "~a~%" ($sparse6_encode g))))
 295   'done)
 296
 297 ;;;;;;;;;;;;;;
 298 ;;;
 299 ;;; dig6 is similar to graph6 but for directed graphs
 300 ;;; (dig6 is used in SAGE)
 301 ;;;
 302
 303 (defmfun $dig6_encode (gr)
 304   (require-digraph 'dig6_decode 1 gr)
 305   (dig6-string gr))
 306
 307 (defun dig6-string (gr)
 308   (let ((n ($graph_order gr))
 309         (names (get-canonical-names (vertices gr)))
 310         (e-val))
 311
 312     ;; encode edges
 313     (setq e-val 1)
 314     (loop for i from 0 to (1- n) do
 315          (loop for j from 0 to (1- n) do
 316               (let ((u (car (rassoc i names)))
 317                     (v (car (rassoc j names))))
 318                 (setq e-val (ash e-val 1))
 319                 (if (is-edge-in-graph (list u v) gr)
 320                     (incf e-val)))))
 321
 322     ;; add zeros to the right
 323     (let ((n1 (mod (* n n) 6)))
 324       (unless (= n1 0)
 325         (setq e-val (ash e-val (- 6 n1)))))
 326
 327     ;; change bits to string
 328     (format nil "~{~c~}" (mapcar #'code-char
 329                                  (append (get-n n) (cdr (get-r e-val))))) ))
 330
 331 (defmfun $dig6_export (graphs fl)
 332   (unless (stringp fl)
 333     (merror "`dig6_export': second argument is not a string."))
 334   (unless ($listp graphs)
 335     (merror "`dig6_export': first argument is not a list."))
 336   (with-open-file (stream fl :direction :output :if-exists :supersede)
 337     (dolist (g (cdr graphs))
 338       (format stream "~a~%" ($dig6_encode g))))
 339   'done)
 340
 341
 342 (defmfun $dig6_decode (str)
 343   ;; get a lisp string
 344   (unless (stringp str)
 345     (merror "`dig6_decode': argument is not a string."))
 346
 347   ;; read bits from string
 348   (if (and (> (length str) 8)
 349            (string= ">>dig6<<" (subseq str 0 8)))
 350       (setq str (subseq str 0)))
 351
 352   ;; read the data
 353   (let ((n) (g) (e-bits) (e-val 0)
 354         (bits (mapcar #'char-code (coerce str 'list))))
 355
 356     (if (< (car bits) 126)
 357         (progn
 358           (setq n (- (car bits) 63))
 359           (setq e-bits (cdr bits)))
 360         (progn
 361           (setq bits (cdr bits))
 362           (setq n (+ (ash (- (car bits) 63) 12)
 363                      (ash (- (cadr bits) 63) 6)
 364                      (- (caddr bits) 63)))
 365           (setq e-bits (cdddr bits))))
 366
 367     (dolist (v e-bits)
 368       (setq e-val (ash e-val 6))
 369       (incf e-val (- v 63)))
 370
 371     ;; remove trailing zeros
 372     (let ((n1 (mod (* n n) 6)))
 373       (unless (= n1 0)
 374         (setq e-val (ash e-val (- n1 6)))))
 375
 376     ;; construct graph
 377     (setq g ($empty_digraph n))
 378     (loop for i from (1- n) downto 0 do
 379          (loop for j from (1- n) downto 0 do
 380               (if (> (boole boole-and e-val 1) 0)
 381                   (add-edge (list j i) g))
 382               (setq e-val (ash e-val -1))))
 383     g))
 384
 385 (defmfun $dig6_import (fl)
 386   (unless (stringp fl)
 387     (merror "`dig6_import': argument is not a string."))
 388   (with-open-file (stream fl)
 389     (let ((lst ()))
 390       (do ((line (read-line stream nil 'eof)
 391                  (read-line stream nil 'eof)))
 392           ((eq line 'eof))
 393         (setq lst (cons ($dig6_decode line) lst)))
 394       `((mlist simp) ,@lst))))