;; VAX mode 1.6e -- for exploring tilings (informally called vaxmacs) ;; Copyright (C) 1996, 1997 David B. Wilson ;; ;; Requires emacs 19.30 or a more recent version. The current version ;; of emacs 19 is 19.34. vaxmacs now also runs under emacs 20. ;; Ask your system administrator to install the latest version of emacs ;; if you don't have 19.30 or a more recent version. ;; ;; To use on MIT math or MSRI machines, place the following three lines ;; at the top of your .emacs file (without the semicolons): ;; ;; (setq auto-mode-alist ;; (cons '("\\.vax$" . vax-mode) auto-mode-alist)) ;; (autoload 'vax-mode (expand-file-name "~dbwilson/vax.el") nil t) ;; ;; To use on MIT Athena machines, place this at the top of your .eamcs file: ;; ;; (setq auto-mode-alist ;; (cons '("\\.vax$" . vax-mode) auto-mode-alist)) ;; (autoload 'vax-mode "/mit/tiling/elisp/vax.el" nil t) ;; (setq vax-mode-hook ;; '(lambda () (setq maple-command "/mit/tiling/bin/mapletty"))) ;; ;; If you're running Windows XP or Windows 2000 and have Maple 7, ;; place this in your .emacs: ;; ;; (setq auto-mode-alist ;; (cons '("\\.vax$" . vax-mode) auto-mode-alist)) ;; (autoload 'vax-mode "vax.el" nil t) ;; (setq vax-mode-hook ;; '(lambda () (setq maple-command "C:\\Program Files\\Maple 7\\BIN.W2000\\cmaple.exe"))) ;; ;; The name of this file goes in the autoload command. ;; These three examples should give you an idea of what to do in general. ;; ;; Once you've setup your .emacs file (and have a suitable version of emacs) ;; you're in business. Whenever you open a file with a .vax extension, the ;; buffer runs in vax mode. Vax mode sets some of the keys to do operations ;; that are useful for making vax files, and sets other keys to compute things ;; like the number of tilings of the region defined by the vax file, the ;; probability that a random tiling contains a certain tile, or even the ;; probability of finding a certain set of tiles in a random tiling. ;; ;; Vax mode includes online documentation for using all of these abilities. ;; To view this documentation, type "?" or "h" in a buffer that is in vax mode. ;; The remainder of this description of vax mode is in the online documenation. ;; ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, version 2 of the License. ;; To view the GNU General Public License, type ^h^c ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; (defvar vax-mode-map nil "Mode map for VAX mode") (defvar vax-face nil "Face for displaying squares deleted from region") (defvar maple-command "maple" "Command to run maple in text mode") (defvar float nil "Floating point / fraction flag variable") (setq lattice-4 '("X")) (setq lattice-6 '("AV" "VA")) (setq lattice-8-4 '("AVVA" "VAAV")) (setq lattice-12-6-4 '(" XVXXVX " " XAXXAX " "XVX XVX" "XAX XAX")) (setq lattice-3+d '("=XXX" "XXXX" "XX=X" "XXXX")) (setq lattice-urban '("UX" "XX")) (defvar lattice lattice-4 "Specifies type of grid we're working in") (defvar vax-rand nil) (defvar highlights nil) (defvar vax-dev nil) (defvar vax-msg nil) (defvar vax-chars ;; d u r l '((?X "1" "1" "1" "1") (?V "" "1" "1" "1") (?A "1" "" "1" "1") (?> "1" "1" "" "1") (?< "1" "1" "1" "" ) (?= "" "" "1" "1") (?I "1" "1" "" "" ) (?U "4" "1" "4" "1")) "Specifies which neighbors (down up right left) that a vertex prefers to be paired with") (defun vax-mode () "Major mode for creating VAX files and computing stuff about the regions they define. A typical VAX file contains any of the characters X, V, A, <, >, =, I, and white space. Described below are 1) The commands for computing with VAX files. 2) The commands to help create VAX files more easily (especially useful when working with non-Cartesian lattices). 3) The VAX file format (Many dominoers are already familiar with this, if you are not, look at this first.) 4) Working with other lattices. Menu of available commands ? show this message Commands for obtaining information from VAX file P make a picture of the region # compute number of tilings p compute prime factorization of number of tilings [ compute q-factorization of q-analogue of number of tilings m compute lots of data with maple g graph the placement probabilities f toggle floating point / fraction d make your own character definition, like A, V, <, I, = you will be prompted for weights for matchings to each to each of a squares four neighbors -- for the predefined characters these weights are all either 0 or 1, but in general the weights may be arbitrary maple expressions . exclude/include current square from current subdeterminant q toggle q-mode Commands for editing VAX file Note that any of the standard VAX characters may be typed without the shift key, capitalization is automatic. z write out an Aztec diamond using lattice r write out rectangle using lattice h write out hexagon using lattice l set the lattice (default is square lattice) k kill to beginning of line ^k kill to end of line 0 clear entire buffer (, ), e macro define and execute ` move cursor up and left ' move cursor up and right / move cursor down and left \\ move cursor down and right VAX mode runs in Picture mode, in which a quarter-plane screen model is used. Printing characters replace instead of inserting themselves with motion afterwards settable by these commands: C-c < Move left after insertion. C-c > Move right after insertion. C-c ^ Move up after insertion. C-c . Move down after insertion. C-c ` Move northwest (nw) after insertion. C-c ' Move northeast (ne) after insertion. C-c / Move southwest (sw) after insertion. C-c \\ Move southeast (se) after insertion. The current direction is displayed in the mode line. The initial direction is right. Whitespace is inserted and tabs are changed to spaces when required by movement. VAX File Format A VAX file is a file format for describing planar bipartite graphs. For most regions that Propp's tiling group is interested in, VAX files tend to be compact and human readable. To make VAX files extra readable, vaxmacs can generate postscript pictures of the graphs they define. The region to be tiled should be given as a pattern of V's, A's, X's, <'s, >'s, ='s, I's, and white space. There are two ways to view a VAX file. In the first, any non-whitespace character represents a vertex of graph, and we are interested in perfect matchings of this graph. In the second, the non-whitespace characters represent units of area in a region that is to be covered by tiles. (These tiles may be dominos, lozenges, diabolos, and the like.) By default two characters that look adjacent in the file (either left, right, up, or down) represent vertices that are adjacent in the graph -- and they are connected unless one (or both) of the characters objects. Different characters object to different sets of connections. X: may be paired in any direction, it has no objections V: objects to being paired DOWN A: objects to being paired UP <: objects to being paired LEFT >: objects to being paired RIGHT =: objects to being paired UP or DOWN I: objects to being paired LEFT or RIGHT For instance, the graphs o--o--o | | o--o--o--o o o and | | | | o--o--o--o o--o--o may be represented as XXX X X and AVVA XXX VAAV There are two mnemonics for remembering the meanings of V,A,<,>. These characters object to connections in their pointed direction. The second mnemonic is that these characters resemble triangles, and if one has a region tiled by equilateral triangles ____ /\\ /\\ /__\\/__\\ \\ /\\ / \\/__\\/ and one wishes to pair up the triangles to form a rhombus-tiling, the triangles that look like V's are the ones that can pair (sort of) leftward, (sort of) rightward, or upward. This region would be represented with AVA VAV The characters = and I are useful for `vertex splitting'. If some vertex in the graph that we wish to represent has high degree, it may be split into three vertices. The middle vertex is connected to only the other two vertices, and these vertices partition the connections of the original vertex to the rest of the graph. Matchings in the new graph are in one-to-one correspondence with matchings in the new graph. When splitting, the middle vertex character is either = or I, indicating that the two vertices on either side of it are EQUAL or IDENTICAL in the original graph. Things you can do with VAX files The most basic question you can ask is how many tilings there are of the region defined by the VAX file. To find out, just type #. Lots more information is available if you type m. The current lattice Almost every region that people care about is a subregion of some infinite regular lattice. Vax mode provides commands that can be used to quickly generate these regions. Use `l' to define the periodic unit of the infinite lattice. The default lattice is the square lattice. To set the lattice to something else, type `l'. This will take you to a menu letting you set the lattice to one of the following predefined lattices square hexagonal square-octagonal square-hexagon-dodecagonal urban-renewal (diabolo-weighted square) or you can define your own lattice, by then typing `g' (for general), and then inputing the repeating blocks of the lattice. For instance, the hexagonal lattice has a 2x2 repeating block consisting of AV VA which could be entered as lgAVVA or since it's predefined, as l6. Once the lattice is defined, the commands for generating regions will automatically use the lattice. For instance, the `r' command for making a rectangle, the `z' command for making an Aztec diamond, and the `h' command for making hexagons, will make their respective shapes using the current lattice. This regions can then be edited and explored. " (interactive) (kill-all-local-variables) (setq goal-column nil) (make-local-variable 'vax-engine) (make-local-variable 'vax-region) (make-local-variable 'vax-mkast) (make-local-variable 'ntilings) (make-local-variable 'vax-lup) (make-local-variable 'vax-minverse) (setq vax-engine 'emaple vax-region nil) (make-local-variable 'blackwhite) (setq blackwhite nil) (make-local-variable 'float) (make-local-variable 'nblack) (make-local-variable 'nwhite) (make-local-variable 'col-labels) (make-local-variable 'col-labeled) (make-local-variable 'row-labels) (make-local-variable 'row-labeled) (make-local-variable 'blackpos) (make-local-variable 'whitepos) (make-local-variable 'col-lists) (make-local-variable 'row-lists) (make-local-variable 'prob-buf) (make-local-variable 'proc) (make-local-variable 'vax-q) (setq proc nil) (setq vax-q nil) (make-local-variable 'lattice) (make-local-variable 'highlights) (if (string< emacs-version "19.30") (make-local-variable 'post-command-hook) (make-local-hook 'post-command-hook)) (setq post-command-hook nil) (if vax-msg () (setq vax-msg t) (if (not (string< emacs-version "19.30")) (message "vaxmacs 1.6e click on the \"VAX\" button for help by David B. Wilson") % "http://http.cs.berkeley.edu/~dbwilson" (message "Ask your system administrator to install a new version of emacs 19") (setq vax-face t) (defun facemenu-remove-all (x y)) (defun facemenu-add-face (s x y)) (defun make-face (s)) (defun set-face-background (s b)) (defun make-face-bold (s p t) nil) (defun invert-face (s)) (defun set-face-underline-p (s b)) (defun set-face-stipple (s l)))) (use-local-map vax-mode-map) ; This provides the local keymap. (setq mode-name "VAX") ; This name goes into the mode line. (setq major-mode 'vax-mode) ; This is how `describe-mode' ; finds the doc string to print. ;; lifted from picture.el (make-local-variable 'picture-killed-rectangle) (setq picture-killed-rectangle nil) (make-local-variable 'tab-stop-list) (setq tab-stop-list (default-value 'tab-stop-list)) (make-local-variable 'picture-tab-chars) (setq picture-tab-chars (default-value 'picture-tab-chars)) (make-local-variable 'picture-vertical-step) (make-local-variable 'picture-horizontal-step) (make-local-variable 'picture-mode-old-truncate-lines) (setq picture-mode-old-truncate-lines truncate-lines) (setq truncate-lines t) (picture-set-motion 0 1) (vax-quit) (run-hooks 'edit-picture-hook 'picture-mode-hook 'vax-mode-hook)) ; Finally, this permits the user to ; customize the mode with a hook. (require 'picture) ;; should do something besides redefine outright (defun picture-set-motion (vert horiz) "Set VERTICAL and HORIZONTAL increments for movement in Picture mode. The mode line is updated to reflect the current direction." (setq picture-vertical-step vert picture-horizontal-step horiz) (vax-mode-line)) (defun vax-mode-line () (setq mode-name (format "VAX%s:%s" (if vax-q "-Q" "") (car (nthcdr (+ 1 (% picture-horizontal-step 2) (* 3 (1+ (% picture-vertical-step 2)))) '(nw up ne left none right sw down se))))) (force-mode-line-update)) (defun vax-qmode () (interactive) (vax-quit) (setq vax-q (not vax-q)) (vax-mode-line)) (if (and (not vax-dev) vax-mode-map) () ; (setq vax-mode-map (make-sparse-keymap)) (setq vax-mode-map (copy-keymap picture-mode-map)) (define-key vax-mode-map "\C-k" 'kill-line) (define-key vax-mode-map "\r" 'newline) (defmacro vax-col (f) `(lambda () (interactive) ;; (facemenu-remove-all (point-min) (point-max)) (if (equal vax-region (buffer-substring-no-properties (point-min) (point-max))) nil (vax-quit) (setq vax-region (buffer-substring-no-properties (point-min) (point-max)))) (catch 'chromatic (catch 'singular (,f))))) (define-key vax-mode-map [menu-bar lattice] (cons "Lattice" (make-sparse-keymap "Lattice"))) (define-key vax-mode-map [menu-bar lattice ?g] (cons "General lattice" '(lambda () (interactive) (vax-get-lattice ?g)))) (define-key vax-mode-map [menu-bar lattice ?u] (cons "Urban renewal lattice" '(lambda () (interactive) (vax-get-lattice ?u)))) (define-key vax-mode-map [menu-bar lattice ?3] (cons "Triangular-and-dual lattice" '(lambda () (interactive) (vax-get-lattice ?3)))) (define-key vax-mode-map [menu-bar lattice ?1] (cons "Dodecagon-hexagon-square lattice" '(lambda () (interactive) (vax-get-lattice ?1)))) (define-key vax-mode-map [menu-bar lattice ?8] (cons "Octagon-square lattice" '(lambda () (interactive) (vax-get-lattice ?8)))) (define-key vax-mode-map [menu-bar lattice ?6] (cons "Hexagon lattice" '(lambda () (interactive) (vax-get-lattice ?6)))) (define-key vax-mode-map [menu-bar lattice ?4] (cons "Square lattice" '(lambda () (interactive) (vax-get-lattice ?4)))) (define-key vax-mode-map [menu-bar gedit] (cons "Graph-Edit" (make-sparse-keymap "Graph-Editting"))) (define-key vax-mode-map [menu-bar gedit ?e] (cons "execute macro" 'call-last-kbd-macro)) (define-key vax-mode-map [menu-bar gedit ?)] (cons "end defining macro" 'end-kbd-macro)) (define-key vax-mode-map [menu-bar gedit ?(] (cons "start defining macro" 'start-kbd-macro)) (define-key vax-mode-map [menu-bar gedit ?z] (cons "Aztec diamond (using lattice)" 'aztec)) (define-key vax-mode-map [menu-bar gedit ?h] (cons "hexagon (using lattice)" 'hexagon)) (define-key vax-mode-map [menu-bar gedit ?r] (cons "rectangle (using lattice)" 'vax-write-rectangle)) (define-key vax-mode-map [menu-bar graphics] (cons "PostScript" (make-sparse-keymap "PostScript"))) (define-key vax-mode-map [menu-bar graphics ?g] (cons "Graph placement probabilities" (vax-col vax-graph))) (define-key vax-mode-map [menu-bar graphics ?P] '("Plot graph of region (using lattice)" . vax-picture)) (define-key vax-mode-map [menu-bar compute] (cons "Compute" (make-sparse-keymap "Compute"))) (define-key vax-mode-map [menu-bar compute ?m] (cons "Placement probabilites of vertex under cursor" (vax-col vax))) (define-key vax-mode-map [menu-bar compute ?p] (cons "Prime factorization of number of tilings" (vax-col vax-primes))) (define-key vax-mode-map [menu-bar compute ?#] (cons "Number of tilings" (vax-col vax-number))) (define-key vax-mode-map [menu-bar vax] (cons "VAX!!" (make-sparse-keymap "VAX"))) ;; (define-key vax-mode-map ;; [menu-bar vax ?d] ;; '("Define new char" . vax-define-char)) (define-key vax-mode-map [menu-bar vax ??] '("General help" . describe-mode)) (define-key vax-mode-map [menu-bar vax ?p] (cons "Primer on the VAX file format" '(lambda () (interactive) (describe-mode) (set-buffer "*Help*") (search-forward "VAX File Format" nil nil 2) (beginning-of-line) (delete-region (point-min) (point)) (search-forward "Things you can do") (beginning-of-line -1) (delete-region (point-max) (point))))) (define-key vax-mode-map [menu-bar help] 'undefined) ; (define-key vax-mode-map "h" 'describe-mode) (define-key vax-mode-map "?" 'describe-mode) (define-key vax-mode-map "P" 'vax-picture) (define-key vax-mode-map "0" 'clear-buffer) (define-key vax-mode-map "r" 'vax-write-rectangle) (define-key vax-mode-map "h" 'hexagon) (define-key vax-mode-map "z" 'aztec) (define-key vax-mode-map "w" 'aztec-window) (define-key vax-mode-map "l" 'vax-get-lattice) (define-key vax-mode-map "k" 'vax-kill-line-backward) (define-key vax-mode-map "(" 'start-kbd-macro) (define-key vax-mode-map ")" 'end-kbd-macro) (define-key vax-mode-map "e" 'call-last-kbd-macro) (define-key vax-mode-map "v" "V") (define-key vax-mode-map "a" "A") (define-key vax-mode-map "x" "X") (define-key vax-mode-map "i" "I") (define-key vax-mode-map "d" 'vax-define-char) (define-key vax-mode-map "s" (vax-col vax-spectrum)) (define-key vax-mode-map "S" (vax-col vax-spectrum-f)) (define-key vax-mode-map "#" (vax-col vax-number)) (define-key vax-mode-map "3" (vax-col vax-number)) (define-key vax-mode-map "p" (vax-col vax-primes)) (define-key vax-mode-map "[" (vax-col vax-qprimes)) (define-key vax-mode-map "]" (vax-col vax-qprimes)) (define-key vax-mode-map "m" (vax-col vax)) (define-key vax-mode-map "g" (vax-col vax-graph)) (define-key vax-mode-map "E" 'vax-change-engine) (define-key vax-mode-map "K" 'vax-show-matrix) (define-key vax-mode-map "M" 'vax-maple-matrix) (define-key vax-mode-map "." (vax-col vax-toggle-highlight)) (define-key vax-mode-map "/" '(lambda () (interactive) (next-line 1) (backward-char))) (define-key vax-mode-map "\\" '(lambda () (interactive) (next-line 1) (forward-char))) (define-key vax-mode-map "`" '(lambda () (interactive) (previous-line 1) (backward-char))) (define-key vax-mode-map "'" '(lambda () (interactive) (previous-line 1) (forward-char))) (define-key vax-mode-map "f" '(lambda () (interactive) (setq float (not float)))) (define-key vax-mode-map "R" '(lambda () (interactive) (load-file (expand-file-name "~dbwilson/elisp/vax.el")))) (define-key vax-mode-map "Q" 'vax-quit) (define-key vax-mode-map "q" 'vax-qmode)) (if vax-dev (setq debug-on-error t)) (defun vax-define-char (chr down up left right) (interactive "cNew VAX character: \nsDownward weight: \nsUpward weight: \nsRightward weight: \nsLeftward weight: ") (setq vax-chars (cons (list chr down up left right) vax-chars))) (defun vax-show-matrix () (interactive) (let ((matbuf (get-buffer-create (concat "*" (buffer-name) " Matrix*"))) (engine vax-engine) (vax-engine 'matrix) (buf (current-buffer))) (set-buffer matbuf) (delete-region (point-min) (point-max)) (set-buffer buf) (vax-make-matrix) (setq vax-engine engine) (pop-to-buffer matbuf))) (defun vax-maple-matrix () "Start maple with matrix defined" (interactive) (require 'comint) (let ((matbuf) (iproc) (engine vax-engine) (vax-engine 'imatrix) (buf (current-buffer)) (prog "maple") (pager (getenv "PAGER"))) (setq matbuf (get-buffer (concat "*" (buffer-name) " Maple*"))) (if (and matbuf (not (kill-buffer matbuf))) nil (setenv "PAGER" "cat") (setq matbuf (make-comint (concat (buffer-name) " Maple") maple-command nil "-q")) (setq iproc (get-buffer-process matbuf)) (set-buffer matbuf) (comint-mode) (setq comint-process-echoes t) (setq comint-prompt-regexp "^> +") (set-buffer buf) (setenv "PAGER" pager) (vax-make-matrix) (process-send-string iproc "interface(quiet=false):\n") (setq vax-engine engine) (set-buffer matbuf) (goto-char (point-max)) (pop-to-buffer matbuf)))) (defun vax-toggle-highlight () (interactive) (if vax-face () (setq vax-face t) (make-face 'vax-face) (set-face-background 'vax-face "orange") (if (not (make-face-bold 'vax-face nil t)) () (invert-face 'vax-face) (set-face-underline-p 'vax-face t)) (set-face-stipple 'vax-face '(3 2 "\001\000"))) (toggle-read-only -1) (vax-get-number) (vax-extract-inverse nil) (cond ((not post-command-hook) (split-window-vertically -5) (other-window 1) (switch-to-buffer prob-buf) (other-window -1) (setq post-command-hook 'vax-foo))) (cond ((not (and blackwhite (aref blackwhite (point))))) ((memq (point) highlights) (setq highlights (delq (point) highlights)) (facemenu-remove-all (point) (+ 1 (point))) (if (> (aref blackwhite (point)) 0) (facemenu-add-face 'region (point) (+ 1 (point))))) (t (setq highlights (cons (point) highlights)) (facemenu-add-face 'vax-face (point) (+ 1 (point))) (if (< (aref blackwhite (point)) 0) (vax-sub-backsub (- (aref blackwhite (point))) t)))) (toggle-read-only 1)) (defun clear-buffer () (interactive) (if (y-or-n-p "Clear entire buffer? ") (kill-region (point-min) (point-max)))) (defun vax-insert (arg) "Insert this character in place of character previously at the cursor." (interactive "p") (move-to-column-force (1+ (current-column))) (delete-char -1) (insert arg) (forward-char -1)) (defun current-line () (interactive) (save-excursion (save-restriction (widen) (beginning-of-line) (count-lines 1 (point))))) (defun hexagon (a b c d) (interactive "*nNorthwest side length: \nnNorth side length: \nnNortheast side length: \nnSoutheast side length: ") (let* ((b (+ b b -1)) (width (+ a b c)) (height (+ d c)) (f (- height a)) (e (- width d f)) (rx) (ry) (x) (y 0) (lrow) (lw) (x0 (current-column)) (y0 (current-line))) (while (< y height) (setq x 0) (setq lrow (nth (mod (+ y y0) (length lattice)) lattice)) (setq lw (length lrow)) (while (< x width) (setq rx (- width 1 x) ry (- height 1 y)) (if (and (>= (+ x y 1) a) (>= (+ rx ry 1) d) (>= (+ rx y 1) c) (>= (+ x ry 1) f)) (vax-insert (aref lrow (mod (+ x x0) lw)))) (picture-forward-column 1) (setq x (+ 1 x))) (setq y (+ 1 y)) (picture-backward-column width) (picture-move-down 1)))) (defun aztec-window (out in) (interactive "*nOrder of outer diamond: \nnOrder of inner diamond: ") (setq out (- (* out 2) 1)) (setq in (- (* in 2) 1)) (let ((i (- out)) (j) (d) (x) (y 0) (lrow) (lw) (x0 (current-column)) (y0 (current-line))) (while (<= i out) (setq j (- out) x 0) (setq lrow (nth (mod (+ y y0) (length lattice)) lattice)) (setq lw (length lrow)) (while (<= j out) (setq d (+ (abs i) (abs j) -1)) (if (and (<= d out) (> d in)) (vax-insert (aref lrow (mod (+ x x0) lw)))) (picture-forward-column 1) (setq j (+ 2 j) x (+ 1 x))) (setq i (+ 2 i) y (+ 1 y)) (picture-backward-column (+ out 1)) (picture-move-down 1)))) (defun aztec (order) (interactive "*nOrder of Aztec diamond: ") (aztec-window order 0)) (defun vax-write-rectangle (width height) (interactive "*nWidth: \nnHeight: ") (let ((i 0) (j) (lh (length lattice)) (lw) (lrow) (x0 (current-column)) (y0 (current-line))) ; (message (format "at %d %d" x0 y0)) (while (< i height) (setq lrow (nth (mod (+ y0 i) lh) lattice)) (setq lw (length lrow)) (setq j 0) (while (< j width) (vax-insert (aref lrow (mod (+ x0 j) lw))) (forward-char 1) (setq j (+ 1 j))) (backward-char width) (picture-move-down 1) (setq i (+ 1 i))))) (defun vax-get-lattice (&optional ty) (interactive) (save-excursion (let ((type nil) (cbuff (current-buffer)) (buff (get-buffer-create "*Supported Lattices*"))) (if ty nil ;; (delete-other-windows) (switch-to-buffer buff t) (delete-region (point-min) (point-max)) (insert "Type the code letter for the underlying lattice from the following choices 4 = square 6 = hexagonal 8 = 8-4, square-octagonal 1 = 12-6-4, square-hexagon-dodecagonal 3 = 3+d, triangular with dual superimposed u = urban-renewal (diabolo-weighted square) g = general lattice (define it yourself) ")) (while (not type) (setq type (or ty (read-char-exclusive))) (cond ((= type ?4) (setq type lattice-4)) ((= type ?6) (setq type lattice-6)) ((= type ?8) (setq type lattice-8-4)) ((= type ?1) (setq type lattice-12-6-4)) ((= type ?3) (setq type lattice-3+d)) ((= type ?u) (setq type lattice-urban)) ((= type ?g) (vax-get-lattice-general)) (t (setq type nil)))) (switch-to-buffer cbuff) (setq lattice type)))) (defun vax-get-lattice-general () (interactive) (let ((str) (strl nil) (i 1)) (while (> (length (setq str (read-string (format "line %d: " i)))) 0) (setq i (+ 1 i)) (setq strl (cons str strl))) (setq type (nreverse strl)))) ;; (defun vax-expand () ;; (interactive) ;; (let ((buff (get-buffer-create "*Expanded graph*")) ;; (cbuff (current-buffer)) ;; (chr) ;; ) ;; (make-frame) ;; (switch-to-buffer-other-frame buff) ;; (set-buffer buff) ;; (goto-char (point-min)) ;; (push-mark) ;; (set-buffer cbuff) ;; (save-excursion ;; (goto-char (point-min)) ;; (while (< (point) (point-max)) ;; (setq chr (aref (buffer-substring (point) (+ 1 (point))) 0)) ;; (forward-char) ;; )))) (defun vax-quit () (interactive) (setq vax-mkast nil) (setq ntilings nil) (setq vax-minverse nil) (setq vax-lup nil) (toggle-read-only -1) (facemenu-remove-all (point-min) (point-max)) (cond (proc (delete-windows-on prob-buf) (delete-process proc) (setq prob-buf nil) (setq proc nil) (setq blackwhite nil) (setq vax-region nil) (setq highlights nil) (setq post-command-hook nil)))) (defun vax-change-engine (symb) (interactive "Sengine to use (maple, matlab, or emaple): ") (if (not (memq symb '(maple matlab emaple))) (message "Bad engine.") (setq vax-engine symb) (vax-quit))) (defun vax-foo () (toggle-read-only 1) (cond ((eq last-command-char ?s) (vax-spectrum)) ((eq last-command-char ?S) (vax-spectrum-f)) (t (if highlights (vax-subdeterminant) (vax-durls))))) (defun vax-subdeterminant () (vax-get-number) (save-excursion (let* ((blacks) (whites) (lst highlights) (nt ntilings) (vax-engine vax-engine) (proc proc) (float float)) (while lst (let ((bw (aref blackwhite (car lst)))) (if (> bw 0) (setq blacks (cons bw blacks)) (setq whites (cons (- bw) whites)))) (setq lst (cdr lst))) (set-buffer prob-buf) (delete-region (point-min) (point-max)) (insert nt " tilings\n") (center-region (point-min) (point-max)) (insert (format "Subdeterminant region has %d black and %d white squares\n" (length blacks) (length whites))) (cond ((= (length blacks) (length whites)) (vax-say (format "blacks := [%d" (car blacks))) (while (setq blacks (cdr blacks)) (vax-say (format ",%d" (car blacks)))) (vax-say "]:\n") (vax-say (format "whites := [%d" (car whites))) (while (setq whites (cdr whites)) (vax-say (format ",%d" (car whites)))) (vax-say "]:\n") (vax-say "dsik := det(submatrix(ikast,whites,blacks)):\n") (vax-say "dsk := det(submatrix(kast,blacks,whites)):\n") (let ((a (vax-query "abs(dsik*adkast)")) (b (vax-query "abs(dsk)")) (c (vax-query "dsik*dsk*abs(adkast)")) (e (vax-query (if float "1.0*abs(dsik)" "abs(dsik)"))) (f (vax-query "abs(dsk)")) (g (vax-query (if float "1.0*(dsik*dsk)" "dsik*dsk")))) (insert a " * " b " = " c "\n") (insert e " * " f " = " g "\n"))))))) (defun vax-durls () (save-excursion (vax-get-number) (let* ((nt ntilings) (durl (vax-durl (point)))) (set-buffer prob-buf) (delete-region (point-min) (point-max)) (insert nt " tilings\n") (insert (nth 1 durl) "\n") (insert (nth 3 durl) " " (nth 2 durl) "\n") (insert (nth 0 durl)) (center-region (point-min) (point-max))))) (defun vax-durl (cp) (save-excursion (let* ((col (current-column)) (up) (down) (right (+ 1 cp)) (left (- cp 1))) (goto-char cp) (cond ((zerop (forward-line 1)) (move-to-column col) (setq down (if (eq cp (point)) nil (point))))) (goto-char cp) (cond ((zerop (forward-line -1)) (move-to-column col) (setq up (point)))) (goto-char cp) (list (vax-prob cp down) (vax-prob cp up) (vax-prob cp right) (vax-prob cp left))))) (defun vax-message (fmt &rest args) (let* ((str (apply 'format fmt args)) (len (length str)) (obuf (get-buffer-create (concat "*" (buffer-name) " Output*"))) (buf (current-buffer))) (delete-windows-on obuf) (if (< len 80) (message str) (set-buffer obuf) (delete-region (point-min) (point-max)) (insert str) (pop-to-buffer obuf) (shrink-window-if-larger-than-buffer) (other-window -1)))) (defun vax-number () (interactive) (if vax-dev (message (current-time-string))) (vax-get-number) (if vax-dev (message (current-time-string))) (vax-message "Region of 2*%d vertices, %s tilings" nblack ntilings)) (defun vax-primes () (interactive) (let ((f (vax-factors))) (vax-message "Region of 2*%d vertices, %s tilings" nblack f))) (defun vax-qprimes () (interactive) (let ((f (vax-qfactors))) (vax-message "Region of 2*%d vertices, %s tilings" nblack f))) (defun vax () (interactive) (vax-get-number) (message "Region of 2*%d vertices, %s tilings" nblack ntilings) (cond ((not (equal ntilings "0")) (vax-extract-inverse nil) (split-window-vertically -5) (other-window 1) (switch-to-buffer prob-buf) (other-window -1) (toggle-read-only 1) (setq post-command-hook 'vax-foo)))) (defun vax-picture () (interactive) (untabify (point-min) (point-max)) (let ((graph-buf) (buf (current-buffer)) (pnt (point)) (lat) (chr) (cur-i 0) (max-i 0) (max-j 0) (region) (graph-name)) (setq graph-name (concat "/tmp/" (buffer-name) "-" (getenv "USER") ".ps")) (setq graph-buf (find-file-noselect graph-name t)) (setq region (buffer-substring-no-properties (point-min) (point-max))) (setq lat (cond ((equal lattice lattice-6) "l6") ((equal lattice lattice-8-4) "l8-4") ((equal lattice lattice-12-6-4) "l12-6-4") ((equal lattice lattice-3+d) "l3+d") (t "l4"))) (goto-char (point-min)) (while (< (point) (point-max)) (setq chr (curchar)) (cond ((eq chr ?\n) (setq cur-i (+ 1 cur-i))) ((eq chr ? )) (t (if (> (current-column) max-j) (setq max-j (current-column))) (if (> cur-i max-i) (setq max-i cur-i)))) (forward-char 1)) (goto-char pnt) (set-buffer graph-buf) (delete-region (point-min) (point-max)) (insert "%!PS-Adobe-2.1 %%Title: picture of graph %%Creator: vaxmacs %%BoundingBox: 72 72 540 720 %%Pages: 1 %%EndComments ") (insert domino-pro) (goto-char (point-max)) (insert "%%Page: graph 1\ngsave\nvax " lat "\n") (insert (format "0 0 %d %d domcenter\n" max-i max-j)) (insert "!\n") (insert region) (insert "!\nshowpage\n%%PageTrailer\ngrestore\n") (insert "%%Trailer\nend\n%%EOF\n") (write-file graph-name) (shell-command (concat "ghostview " graph-name "")) (message "Hope you liked the graphics.") (set-buffer buf))) (defun vax-graph () (interactive) (vax-get-number) (let ((pnt (point)) (chr) (durl) (graph-buf) (buf (current-buffer)) (lcm) (str) (cur-i 0) (max-i 0) (max-j 0) (graph-name)) (message "Region of 2*%d vertices, %s tilings" nblack ntilings) (cond ((not (equal ntilings "0")) (vax-extract-inverse t) (setq str (concat ntilings " = " (vax-factors))) (setq lcm (vax-lcm)) (setq graph-name (concat "/tmp/" (buffer-name) "-" (getenv "USER") ".ps")) (setq graph-buf (find-file-noselect graph-name t)) (set-buffer graph-buf) (delete-region (point-min) (point-max)) (insert "%!PS-Adobe-2.1 %%Title: edge probabilities %%Creator: vaxmacs %%BoundingBox: 72 72 540 720 %%Pages: 2 %%EndComments ") (insert domino-pro) (goto-char (point-max)) (insert "% " str " tilings\n") (insert "% edge probabilities have denominator " lcm "\n") (insert "%%Page: grays 1\ngsave\ngrays\n") ;; (insert "72 72 moveto 540 72 lineto 540 720 lineto 72 720 lineto closepath stroke\n") (insert "!\n") (set-buffer buf) (goto-char (point-min)) (while (< (point) (point-max)) (setq chr (curchar)) (cond ((eq chr ?\n) (setq cur-i (+ 1 cur-i)) (set-buffer graph-buf) (insert "\n") (set-buffer buf)) ((or (eq chr ? ) (< (aref blackwhite (point)) 0)) (set-buffer graph-buf) (insert " ") (set-buffer buf)) (t (if (> (current-column) max-j) (setq max-j (current-column))) (if (> cur-i max-i) (setq max-i cur-i)) (setq durl (vax-durl (point))) (setq str (mapconcat (lambda (str) (vax-query (concat lcm "*" str))) durl " ")) (setq durl (mapcar (lambda (str) (string-to-int (vax-query (concat "round(255*(" str "))")))) (vax-durl (point)))) (set-buffer graph-buf) (insert "N" str " ") (insert (format "P%02x%02x%02x%02x" (nth 2 durl) (nth 1 durl) (nth 3 durl) (nth 0 durl))) (set-buffer buf))) (forward-char 1)) (set-buffer graph-buf) (search-backward "!") (insert (format "0 0 %d %d domcenter\n" max-i max-j)) (previous-line 1) (setq str (buffer-substring (point) (point-max))) (goto-char (point-max)) (insert "!\nshowpage\n%%PageTrailer\ngrestore\n") (insert "%%Page: numbers 2\ngsave\n(" lcm ") nums\n") (insert str) (insert "!\nshowpage\n%%PageTrailer\ngrestore\n") (insert "%%Trailer\nend\n%%EOF\n") (write-file graph-name) (shell-command (concat "ghostview " graph-name "")) (message "Hope you liked the graphics.") (set-buffer buf) (goto-char pnt))))) (defun vax-lcm () (interactive) (let ((float nil) (pnt (point)) (lcm "1")) (goto-char (point-min)) (while (< (point) (point-max)) (if (and (aref blackwhite (point)) (> (aref blackwhite (point)) 0)) (setq lcm (vax-query (concat "ilcm(" (mapconcat (lambda (str) (concat "denom(" str "),")) (vax-durl (point)) "") lcm ")")))) (forward-char 1)) (goto-char pnt) lcm)) (defun curchar () (aref (buffer-substring (point) (+ 1 (point))) 0)) (defun vax-number-vertices-scan () ;; Assign to each point a row or column number, starting with +/-1 ;; or 0 if not in region (setq blackwhite (make-vector (+ 2 (point-max)) nil)) (setq nblack 0) (setq nwhite 0) (let ((pnt (point)) (chr) (row 1) (col 0)) (goto-char (point-min)) (while (< (point) (point-max)) (setq col (+ 1 col)) (setq chr (curchar)) (cond ((eq chr ?\n) (setq row (+ 1 row)) (setq col 0)) ((eq chr ? )) ((not (assoc chr vax-chars)) (error "Unknown character %c" chr)) ((zerop (logand 1 (logxor row col))) (setq nblack (+ 1 nblack)) (aset blackwhite (point) nblack)) (t (setq nwhite (+ 1 nwhite)) (aset blackwhite (point) (- nwhite)))) (forward-char 1)) (goto-char pnt)) (if (zerop (- nblack nwhite)) (let ((i (point-min)) (perm (nonrandom-perm nblack)) (ind)) (if vax-dev (message "forward/backward scan")) (while (< i (point-max)) (if (setq ind (aref blackwhite i)) (aset blackwhite i (* (if (< ind 0) -1 1) (aref perm (abs ind))))) (setq i (+ 1 i)))))) (defun nonrandom-perm (n) (interactive) (let* ((b (make-vector (+ 1 n) nil)) (i 0) (j (1+ n)) (cnt 0)) (catch 'done (while t (if (> (setq cnt (1+ cnt)) n) (throw 'done b)) (aset b (setq i (1+ i)) cnt) (if (> (setq cnt (1+ cnt)) n) (throw 'done b)) (aset b (setq j (1- j)) cnt))))) (defun random-perm (n) (interactive) (let* ((m (* 2 n)) (a (make-vector m nil)) (b (make-vector (+ 1 n) nil)) (i 1) (j)) (while (<= i n) (while (aref a (setq j (random m)))) (aset a j i) (setq i (+ i 1))) (setq i 0 j 0) (while (< j m) (if (aref a j) (aset b (setq i (+ i 1)) (aref a j))) (setq j (+ j 1))) b)) ;; This procedure does nested-disection. But the ordering produced ;; seems to make factorization take longer. :-( ;; On an order 16 Aztec diamond timings are ;; 0:30 emaple scan order > ;; 0:31 emaple forward/backward scan order > ;; 1:25 emaple nested disection thick=2, /20, > ;; 1:35 emaple nested disection thick=2, /20, normal ;; 1:58 emaple random > ;; 2:36 emaple nested disection thick=2, /20, < ;;; Times below included time delays for displaying nest-disection ;; 2:26 emaple nested disection thick=2, /20 ;; 2:29 emaple nested disection thick=2, /20 ;; 3:39 emaple forward/backward scan order ;; 3:46 emaple scan order ;; 6:26 emaple nested disection thick=1, /20 ;; 13:27 emaple random order ;; 30:20 maple scan order ;; 30:47 maple nested disection thick=2, /20 ;; 30:59 maple nested disection thick=1, /20 (defun vax-number-vertices (&optional srow erow scol ecol) ;; Assign to each point a row or column number, starting with +/-1 ;; Do a nest-disection ordering (cond ((not (and srow erow scol ecol)) (message "Finding nest-disection ordering of vertices") (facemenu-remove-all (point-min) (point-max)) (setq blackwhite (make-vector (+ 2 (point-max)) nil)) (setq nblack 0) (setq nwhite 0) (let ((rowsizes (make-vector (+ 2 (point-max)) nil)) (thick 2) (colsizes (make-vector (+ 2 (point-max)) nil))) (vax-number-vertices 1 (point-max) 0 (point-max)))) ((or (> srow erow) (> scol ecol)) 0) ((and (= srow erow) (= scol ecol)) (if (and (progn (goto-line srow) (< (point) (point-max))) (progn (move-to-column scol) (= scol (current-column)))) (let ((chr (curchar))) (cond ((eq chr ?\n) 0) ((eq chr ? ) 0) ((not (assoc chr vax-chars)) (error "Unknown character %c" chr)) ((zerop (logand 1 (logxor srow scol 1))) (setq nblack (+ 1 nblack)) (facemenu-add-face 'region (point) (+ 1 (point))) (sit-for 0) (aset blackwhite (point) nblack) 1) (t (setq nwhite (+ 1 nwhite)) (facemenu-add-face 'highlight (point) (+ 1 (point))) (sit-for 0) (aset blackwhite (point) (- nwhite)) 1))) 0)) ((and (<= erow (+ srow 3)) (<= (- erow srow) (- ecol scol))) (+ (vax-number-vertices srow erow scol (/ (+ scol ecol) 2)) (vax-number-vertices srow erow (+ 2 (/ (+ scol ecol) 2)) ecol) (vax-number-vertices srow erow (1+ (/ (+ scol ecol) 2)) (1+ (/ (+ scol ecol) 2))))) ((and (<= ecol (+ scol 3)) (<= (- ecol scol) (- erow srow))) (+ (vax-number-vertices srow (/ (+ srow erow) 2) scol ecol) (vax-number-vertices (+ 2 (/ (+ srow erow) 2)) erow scol ecol) (vax-number-vertices (1+ (/ (+ srow erow) 2)) (1+ (/ (+ srow erow) 2)) scol ecol))) (t (let ((chr) (row) (col) (cnt) (left) (right) (middle) (best) (val) (valbest) (rbest) (lbest) (mbest)) (setq row srow) (while (<= row erow) (aset rowsizes row 0) (setq row (1+ row))) (setq col scol) (while (<= col ecol) (aset colsizes col 0) (setq col (1+ col))) ;; gather row and column statistics (catch 'at-end (setq cnt 0) (setq row srow) (while (<= row erow) (goto-line row) (setq col scol) (move-to-column col) (if (= col (current-column)) (catch 'row-end (while (<= col ecol) (if (= (point) (point-max)) (throw 'at-end nil)) (setq chr (curchar)) (cond ((eq chr ?\n) (throw 'row-end nil)) ((eq chr ? )) ((not (assoc chr vax-chars)) (error "Unknown character %c" chr)) (t (setq cnt (1+ cnt)) (aset rowsizes row (1+ (aref rowsizes row))) (aset colsizes col (1+ (aref colsizes col))))) (setq col (+ 1 col)) (forward-char 1)))) (setq row (1+ row)))) ;; identify the best row or column cut (if (zerop cnt) 0 (setq valbest nil) (setq left 0 middle (+ (aref rowsizes srow) ;; thick (aref rowsizes (1+ srow))) ;; thick right (- cnt middle) row srow) (while (catch 'at-end (setq val (+ (expt left 1.5) (expt right 1.5) (/ (expt middle 3) 20.0))) (if (or (not valbest) (< val valbest)) (setq best (- row) lbest left rbest right mbest middle valbest val)) (setq left (+ left (aref rowsizes row)) row (1+ row)) (if (or (> (+ row thick -1) erow) (= right 0)) (throw 'at-end nil)) (setq right (- right (aref rowsizes (+ row thick -1))) middle (- cnt left right)))) (setq left 0 middle (+ (aref colsizes scol) ;; thick (aref colsizes (1+ scol))) ;; thick right (- cnt middle) col scol) (while (catch 'at-end (setq val (+ (expt left 1.5) (expt right 1.5) (/ (expt middle 3) 20.0))) (if (or (not valbest) (< val valbest)) (setq best col lbest left rbest right mbest middle valbest val)) (setq left (+ left (aref colsizes col)) col (1+ col)) (if (or (> (+ col thick -1) ecol) (= right 0)) (throw 'at-end nil)) (setq right (- right (aref colsizes (+ col thick -1))) middle (- cnt left right)))) (if vax-dev (message "Dissecting %d" best)) ;; disect along the best cut (cond ((> 0 best) (setq row (- best)) (if (not (= lbest (vax-number-vertices srow (- row 1) scol ecol))) (error)) (if (not (= rbest (vax-number-vertices (+ row thick) erow scol ecol))) (error)) (if (not (= mbest (vax-number-vertices row (+ row thick -1) scol ecol))) (error)) (+ lbest rbest mbest)) (t (setq col best) (if (not (= lbest (vax-number-vertices srow erow scol (- col 1)))) (error)) (if (not (= rbest (vax-number-vertices srow erow (+ col thick) ecol))) (error)) (if (not (= mbest (vax-number-vertices srow erow col (+ col thick -1)))) (error)) (+ lbest rbest mbest)))))))) (defun vax-record-positions () (setq blackpos (make-vector (1+ nblack) nil)) (setq whitepos (make-vector (1+ nwhite) nil)) (let ((i (point-min)) (node)) (while (< i (point-max)) (if (setq node (aref blackwhite i)) (if (< 0 node) (aset blackpos node i) (aset whitepos (- node) i))) (setq i (1+ i))))) (defun vax-make-matrix () (interactive) (if (and vax-mkast (not (memq vax-engine '(matrix imatrix)))) vax-mkast (untabify (point-min) (point-max)) (setq float nil) (if highlights (facemenu-remove-all (point-min) (point-max))) (setq highlights '()) (message "Numbering vertices") (vax-number-vertices-scan) (if (or (zerop (- nblack nwhite)) (memq vax-engine '(matrix imatrix))) nil (message (format "Zero tilings: %d black vs %d white vertices" nblack nwhite)) (throw 'chromatic nil)) (vax-record-positions) (facemenu-remove-all (point-min) (point-max)) (vax-start-engine) (message "Constructing Kasteleyn matrix") (let ((pnt (point)) (chr) (line 0) (pnta) (pntb) (stra) (strb) (i) (maxi) (sign) (row 1) (col 0) (len) (rowchr) (colchr)) ;; Define the matrix (goto-char (point-min)) (setq stra "") (setq pnta nil) (while (< (point) (point-max)) (setq pntb (point)) (forward-line) (setq strb (buffer-substring pntb (point))) (setq maxi (- (length strb) 1)) (setq i 0) (setq line (+ 1 line)) (while (< i maxi) (if (and (setq row (aref blackwhite (+ pntb i))) (setq col (aref blackwhite (+ pntb i 1))) (setq rowchr (assoc (aref strb i) vax-chars)) (setq colchr (assoc (aref strb (+ 1 i)) vax-chars)) (setq rowchr (nth 3 rowchr)) ; right (setq colchr (nth 4 colchr)) ; left (< 0 (length rowchr)) (< 0 (length colchr))) (vax-kast row col (format "(%s)*(%s)" rowchr colchr))) (setq i (+ 1 i))) (setq maxi (min (length stra) (length strb))) (setq i 0) (setq sign 1) (while (< i maxi) (if (aref blackwhite (+ pntb i)) (setq sign (- sign))) (if (and (setq row (aref blackwhite (+ pnta i))) (setq col (aref blackwhite (+ pntb i))) (setq rowchr (assoc (aref stra i) vax-chars)) (setq colchr (assoc (aref strb i) vax-chars)) (setq rowchr (nth 1 rowchr)) ; down (setq colchr (nth 2 colchr)) ; up (< 0 (length rowchr)) (< 0 (length colchr))) (vax-kast row col (format "%s%s(%s)*(%s)" (if (= sign -1) "-" " ") (if (not vax-q) "" (format "q^(%s%d)*" (if (zerop (mod (+ i line) 2)) "-" "") i)) rowchr colchr))) (setq i (+ 1 i))) (setq stra strb) (setq pnta pntb)) (goto-char pnt)) (if (not (memq vax-engine '(matrix imatrix))) (setq vax-mkast t)))) ;; Functions for actually computing using a backend engine such ;; as maple or matlab (defun vax-say (str) (process-send-string proc str)) (defun vax-start-engine () (if (memq vax-engine '(matrix imatrix)) nil (setq prob-buf (get-buffer-create (concat "*" (buffer-name) " Probabilities*"))) (let ((process-connection-type nil)) ; Use a pipe. (setq proc (apply 'start-process "engine" prob-buf (cond ((memq vax-engine '(maple emaple)) (list maple-command "-q")) ((eq vax-engine 'matlab) (list "/mit/matlab/linuxbin/matlab" "-tty"))))) (set-process-filter proc 'extract-line) (process-kill-without-query proc))) (cond ((eq vax-engine 'maple) (vax-say "with(linalg,det,inverse,submatrix):\n") (vax-say (format "kast:=array(sparse,1..%d,1..%d):\n" nblack nwhite))) ((eq vax-engine 'matrix) (let ((str (format "kast :=array(sparse,1..%d,1..%d):\n" nblack nwhite))) (save-excursion (set-buffer matbuf) (insert "with(linalg):\n") (insert str)))) ((eq vax-engine 'imatrix) (let ((str (format "kast :=array(sparse,1..%d,1..%d):\n" nblack nwhite))) (process-send-string iproc "interface(quiet=true):\n") (process-send-string iproc "with(linalg):\n") (process-send-string iproc stembridge) (process-send-string iproc str))) ((eq vax-engine 'emaple) (message "starting emacs-maple engine") (vax-say "with(linalg,det,inverse,submatrix):\n") (vax-say (format "kast :=array(sparse,1..%d,1..%d):\n" nblack nwhite)) (vax-say (format "nzero:=array(sparse,1..%d,1..%d):\n" nblack nwhite)) (vax-say (format "lu :=array(sparse,1..%d,1..%d):\n" nblack nwhite)) (setq col-labels (make-vector (+ 1 nblack) nil)) (setq col-labeled (make-vector (+ 1 nblack) nil)) (setq row-labels (make-vector (+ 1 nblack) nil)) (setq row-labeled (make-vector (+ 1 nblack) nil)) (setq row-lists (make-vector (+ 1 nblack) nil)) (setq col-lists (make-vector (+ 1 nblack) nil))) ((eq vax-engine 'matlab) (discard-lines 22) (vax-say "format compact\n") (vax-say (format "kast(%d,%d);\n" nblack nwhite))))) ;; Set entry sq1, sq2 of the Kasteleyn matrix to str (defun vax-kast (sq1 sq2 str) (let ((sq1 (max sq1 sq2)) (sq2 (- (min sq2 sq1)))) (cond ((eq vax-engine 'maple) (vax-say (format "kast[%d,%d] := %s:\n" sq1 sq2 str))) ((eq vax-engine 'matrix) (save-excursion (set-buffer matbuf) (insert (format "kast[%d,%d] := %s:\n" sq1 sq2 str)))) ((eq vax-engine 'imatrix) (process-send-string iproc (format "kast[%d,%d] := %s:\n" sq1 sq2 str))) ((eq vax-engine 'emaple) (vax-say (format "kast[%d,%d] := %s:\n" sq1 sq2 str)) (vax-say (format "nzero[%d,%d] := 1:\n" sq1 sq2)) (vax-say (format "lu [%d,%d] := %s:\n" sq1 sq2 str)) (aset row-lists sq1 (cons sq2 (aref row-lists sq1))) (aset col-lists sq2 (cons sq1 (aref col-lists sq2)))) ((eq vax-engine 'matlab) (vax-say (format "kast(%d,%d) = %s;\n" sq1 sq2 str)))))) ;(message (concat "lu = " (vax-query "[[lu[1,1],lu[1,2]],[lu[2,1],lu[2,2]]]"))) (defun smessage (str) (save-excursion (set-buffer "*scratch*") (goto-char (point-max)) (insert str))) (defun vax-get-number () (interactive) (vax-make-matrix) (if ntilings ntilings (cond ((eq vax-engine 'maple) (vax-say "dkast := linalg[det](kast):\n")) ((eq vax-engine 'matlab) (vax-say "dkast = det(kast);\n")) ((eq vax-engine 'emaple) (vax-extract-lup) (cond (vax-dev (smessage (format "%S" col-labels)) (smessage (format "%S" col-labeled)) (smessage (format "%S" row-labels)) (smessage (format "%S" row-labeled)))) (vax-say "dkast:=1:\n") (let ((l 1)) (while (<= l nblack) (vax-say (format "dkast := simplify(dkast * lu[%d,%d]):\n" (aref row-labeled l) (aref col-labeled l))) (setq l (1+ l)))))) (vax-say (if vax-q "adkast := sort(expand(dkast)):\n" "adkast := abs(dkast):\n")) (setq ntilings (vax-query "adkast")))) ;; Find a L-U-P decomposition of the Kasteleyn matrix ;; Given row, return list of those columns on which we can reduce (defun vax-pos-cols (r) (let ((ans nil) (cols (aref row-lists r))) (while cols (if (not (or (aref col-labels (car cols)) (equal "true" (vax-query (format "evalb(0=lu[%d,%d])" r (car cols)))))) (setq ans (cons (car cols) ans))) (setq cols (cdr cols))) (if ans (sort ans '>) (message "Zero tilings, insufficient connectivity") (throw 'singular nil)))) (defun vax-extract-lup-code (nblack blackpos whitepos col-labels col-labeled row-labels row-labeled col-lists row-lists) (message "Computing LU-factorization of Kasteleyn matrix") (let ((rlst nil) (cnt) (r) (c) (pos-cols) (cols) (rows) (i) (j)) ; r and c are the row and column for the current reduction ; i and j iterate through the rows and columns that reductions are done on (setq r nblack) (while (>= r 1) (setq rlst (cons r rlst)) (setq r (1- r))) (setq cnt 0) (while rlst (setq cnt (1+ cnt)) (setq r (car rlst)) (setq rlst (cdr rlst)) (setq pos-cols (vax-pos-cols r)) (setq c (car pos-cols)) (setq pos-cols (cdr pos-cols)) (aset col-labels c cnt) (aset col-labeled cnt c) (aset row-labels r cnt) (aset row-labeled cnt r) (facemenu-add-face 'region (aref blackpos r) (1+ (aref blackpos r))) (facemenu-add-face 'highlight (aref whitepos c) (1+ (aref whitepos c))) (sit-for 0) (setq rows (aref col-lists c)) (while rows (setq i (car rows)) (if (aref row-labels i) () (vax-say (format "alpha:= simplify(lu[%d,%d] / lu[%d,%d]):\n" i c r c)) (vax-say (format "lu[%d,%d] := alpha:\n" i c)) (setq cols pos-cols) (while cols (setq j (car cols)) (if (aref col-labels j) () (vax-say (format "lu[%d,%d] := simplify(lu[%d,%d] - alpha*lu[%d,%d]):\n" i j i j r j)) (cond ((equal "0" (vax-query (format "nzero[%d,%d]" i j))) (vax-say (format "nzero[%d,%d]:=1:\n" i j)) (aset row-lists i (cons j (aref row-lists i))) (aset col-lists j (cons i (aref col-lists j)))))) (setq cols (cdr cols)))) (setq rows (cdr rows)))))) (defun vax-factors () (interactive) (vax-get-number) (cond ((memq vax-engine '(maple emaple)) (message "Factoring.") (if vax-q (maple-query "factor(adkast)") (maple-query "ifactor(adkast)"))) ((eq vax-engine 'matlab) (format "Use maple to factor!")))) (defun vax-qfactors () (interactive) (cond ((memq vax-engine '(maple emaple)) (if (not vax-q) (vax-qmode)) (vax-get-number) (message "Q-factoring.") (vax-say stembridge) (maple-query "qfactor(adkast)")) (t (message "Must be using maple.")))) (defun vax-extract-inverse (all-of-it) (vax-make-matrix) (if vax-minverse vax-minverse (if all-of-it (message "Inverting Kasteleyn matrix")) (cond ((eq vax-engine 'maple) (vax-say "ikast := linalg[inverse](kast):\n")) ((eq vax-engine 'matlab) (vax-say "ikast = inv(kast);\n")) ((eq vax-engine 'emaple) (vax-extract-lup) (vax-say (format "ikast := array(sparse,1..%d,1..%d):\n" nwhite nblack)) (vax-say (format "vec := array(1..%d):\n" nblack)) (vax-say (format "wht := array(1..%d):\n" nwhite)) (if all-of-it (let ((r- 1)) (while (<= r- nwhite) (vax-sub-backsub r- nil) (facemenu-remove-all (aref whitepos r-) (1+ (aref whitepos r-))) (sit-for 0) (setq r- (1+ r-))))))) (setq vax-minverse t))) (defun vax-sub-backsub-code (r- saveall vax-engine nwhite col-labels col-labeled col-lists row-labeled) (let ((status (vax-query (format "wht[%d]" r-)))) (if (or (not (eq vax-engine 'emaple)) (equal status "2") (and (equal status "1") (not (eq t saveall)))) status ;; already computed ;; r, j, i are virtual coordinates, r-, i-, j- are physical coords (let ((r (aref col-labels r-)) (j) (j-) (i) (i-) (rows)) (setq j 0) (while (< (setq j (1+ j)) r) (vax-say (format "vec[%d]:=0:\n" j))) (setq j (- r 1)) (while (<= (setq j (1+ j)) nwhite) (vax-say "dot:=0:\n") (setq j- (aref col-labeled j)) (setq rows (aref col-lists j-)) (while rows (setq i (car rows)) (if (< i j) (vax-say (format "dot:= dot+vec[%d]*lu[%d,%d]:\n" i (aref row-labeled i) j-))) (setq rows (cdr rows))) (vax-say (format "vec[%d]:=(%s-dot)/lu[%d,%d]:\n" j (if (= j r) "1" "") (aref row-labeled j) j-))) (setq j (1+ nwhite)) (while (> (setq j (1- j)) 0) (vax-say "dot:=0:\n") (setq j- (aref col-labeled j)) (setq rows (aref col-lists j-)) (while rows (setq i (car rows)) (if (> i j) (vax-say (format "dot:= dot+vec[%d]*lu[%d,%d]:\n" i (aref row-labeled i) j-))) (setq rows (cdr rows))) (vax-say (format "vec[%d]:=vec[%d]-dot:\n" j j)) (if (or saveall (not (equal "0" (vax-query (format "kast[%d,%d]" j r-))))) (vax-say (format "ikast[%d,%d]:=vec[%d]:\n" r- j j)))) (vax-say (format "wht[%d]:=%d:\n" r- (if saveall 2 1))) (if saveall "2" "1"))))) (setq vax-sub-backsub-byte (byte-compile 'vax-sub-backsub-code)) (setq vax-extract-lup-byte (byte-compile 'vax-extract-lup-code)) (defun vax-sub-backsub (r- saveall) (funcall vax-sub-backsub-byte r- saveall vax-engine nwhite col-labels col-labeled col-lists row-labeled)) (defun vax-extract-lup () (if vax-lup vax-lup (funcall vax-extract-lup-byte nblack blackpos whitepos col-labels col-labeled row-labels row-labeled col-lists row-lists) (setq vax-lup t))) (defun vax-prob (pt1 pt2) (if (and pt1 pt2) (let ((sq1 (aref blackwhite pt1)) (sq2 (aref blackwhite pt2))) (if (and sq1 sq2) (let ((sqb (max sq1 sq2)) (sqw (- (min sq2 sq1)))) (vax-query (format (cond ((eq vax-engine 'maple) "%s(kast[%d,%d])*(ikast[%d,%d])") ((eq vax-engine 'emaple) (cond ((equal "2" (vax-sub-backsub sqw 1)) (facemenu-remove-all (aref whitepos sqw) (1+ (aref whitepos sqw))) (sit-for 0))) "%s(kast[%d,%d])*(ikast[%d,%d])") ((eq vax-engine 'matlab) "%s(kast(%d,%d))*(ikast(%d,%d))")) (if float "1.0*" "") sqb sqw sqw sqb))) "0")) "0")) (defun vax-spectrum () (interactive) (toggle-read-only 1) (vax-say "spectrum := linalg[eigenvals](linalg[multiply](kast,linalg[htranspose](kast))):\n") (save-excursion (let* ((spectrum (maple-query "[spectrum]"))) (set-buffer prob-buf) (delete-region (point-min) (point-max)) (insert spectrum)))) (defun vax-spectrum-f () (interactive) (toggle-read-only 1) (vax-say "spectrum := evalf(linalg[eigenvals](linalg[multiply](kast,linalg[htranspose](kast)))):\n") (save-excursion (let* ((spectrum (maple-query "[spectrum]"))) (set-buffer prob-buf) (delete-region (point-min) (point-max)) (insert spectrum)))) (defun vax-query (str) (cond ((memq vax-engine '(maple emaple)) (maple-query str)) ((eq vax-engine 'matlab) (matlab-query str)))) (defun maple-query (str) (let ((mreading "") (manswer)) (vax-say (concat "printf(`%A\\n`," str ");\n")) (while mreading (accept-process-output proc)) manswer)) (defun matlab-query (str) (let ((mreading "") (manswer)) (vax-say (concat "disp(" str ")\n")) (while mreading (accept-process-output proc)) (substring manswer 5))) ;; Kill presumed 5 leading spaces (defun discard-lines (n) (cond ((> n 0) (let ((mreading "") (manswer)) (while mreading (accept-process-output proc))) (discard-lines (- n 1))))) (defun extract-line (trash str) (let ((data (match-data)) (place (string-match "[\r\n]" str))) (store-match-data data) (setq mreading (concat mreading (substring str 0 place))) (cond (place (if (not (equal (+ 1 place) (length str))) (progn (message "read error") (beep) (switch-to-buffer (process-buffer proc)) (insert mreading (substring str place)) (set-process-filter trash t) (accept-process-output proc))) (setq manswer mreading) (setq mreading nil))) mreading)) (defun vax-kill-line-backward () (interactive) (let* ((end (if (looking-at "$") 0 1)) (pnt (+ (point) end))) (beginning-of-line) (kill-region (point) pnt) (insert (make-string (- pnt (point)) ? )) (backward-char end))) (defvar stembridge nil "John Stembridge's qfactor code.") (setq stembridge "############################# # # qfactor(expr,q), where expr is a rational function of q, rewrites expr in # the form q^a*R(q)*N(q)/D(q), where R(q) is a ratio of (1-q^i)'s and N,D # are polynomials with nonzero constant term, not divisible by any cyclotomic # polynomial. If the second argument is missing, it is presumed to be q. # qfactor:=`qseries/qfactor`: `qseries/qfactor`:=proc() local i,Q,poly,quot,ldeg,bound,res,div; if nargs>1 then Q:=args[2] else Q:=q fi; poly:=args[1]; if type(poly,polynom(rational,Q)) then ldeg:=ldegree(poly,Q); poly:=poly/Q^ldeg; bound:=`qseries/bound`(degree(poly,Q)); res:=1; for i from 1 while i<=bound do; if i>1 then div:=numtheory['cyclotomic'](i,Q) else div:=1-Q fi; while divide(poly,div,'quot') do; poly:=quot; res:=res*`qseries/cycle`(i,Q); bound:=`qseries/bound`(degree(poly,Q)); od; od; Q^ldeg*res*poly; elif type(poly,ratpoly(rational,Q)) then normal(poly); `qseries/qfactor`(numer(%),Q)/`qseries/qfactor`(denom(%),Q) else ERROR(`must be a rational function of `.Q) fi; end: # # cycle(n) expresses the nth cyclotomic poly as a ratio of (1-q^i)'s. # cycle(n,q) specify variable name # `qseries/cycle`:=proc(); `qseries/mycycle`(args[1]); if nargs>1 then subs(_q=args[2],%) else subs(_q=q,%) fi; end: `qseries/mycycle`:=proc(n) local d, divs, res; option remember; res:=(1-_q^n); divs:=numtheory['divisors'](n) minus {n}; for d in divs do res:=res/`qseries/mycycle`(d) od; res; end: # # bound(n) computes an upper bound for the largest m such that phi(m)<=n. # Relies on the fact that if n < phi(product of the first i+1 primes), # then an upper bound for m is n/(product of (1-1/p_j) for the first i # primes p_j). # `qseries/bound`:=proc(n) local k,Phi,i; k:=1; Phi:=1; for i while n>=Phi do; ithprime(i); k:=k*(1-1/%); Phi:=Phi*(%%-1); od; trunc(n/k); end: ") (defvar domino-pro nil "Postscript prolog for graphics.") (setq domino-pro "%%BeginProlog % domino prologue, $Date: 2002/03/21 05:00:32 $ 80 dict begin % The picture itself is stored compactly in an ASCII representation % that is typically human-readable. The postscript reads through this % ASCII picture, interprets the characters appropriately, and draws % suitable graphics. % The user can specify one of a variety of methods for displaying % the ASCII picture. These methods are defined below. The next several % functions are for defining the postscript interpreter that reads the % the ASCII picture. \"!\" starts the interpreter. A display method can % define graphics for any given character, but typically \"!\" is defined % to end the picture. % Character coordinates are (i,j), where i is row, j is column. % Any ASCII character's graphic program can access these coordinates. /! {/i 0 def /j 0 def {cdict currentfile read pop get exec} loop} bind def /cdict 256 array def % The dictionary of character definitions /cdef % () {} % Define a char to do program {exch 0 get exch bind cdict 3 1 roll put} def /codef % () {} % Define a char to do program at the % char's page location, increment j {exch 0 get exch bind [ {org} {} forall 2 index {} forall {incr grestore} {} forall ] cvx exch pop cdict 3 1 roll bind put} def /ccdef % () {} {}% Define a char to do program at the % char's page location when cond is % true, increment j {/cond exch cvlit def /prog exch bind cvlit def 0 get [ cond {} forall [ {org} {} forall prog {} forall {grestore} {} forall ] cvx {if incr} {} forall ] cvx cdict 3 1 roll bind put} def /cpdef % () {} % Define a char to do program at the % char's page location when i and j % have the same parity, increment j {{i j xor 1 and 0 eq} ccdef} def /incr {/j j 1 add def} bind def /stdchr { % standard character definitions ( ) {incr} cdef (!) {exit} cdef (\\n) {/i i 1 add def /j 0 def} cdef (\\() {{currentfile 1 string readstring pop 0 get (\\)) 0 get eq {exit} if} loop} cdef } def % View as lozenge tiling /lozenges { stdchr /pos {hexpos} bind def (A) {0 rot 1 0 0 lozenge} cpdef (V) {0 rot cliff} cpdef (<) {120 rot 1 0.92 0 lozenge} cpdef (>) {240 rot 0 0 1 lozenge} cpdef } def % View as domino tiling /dominos { stdchr (A) {270 rot 1 0 0 WT} cpdef (V) {90 rot 0 1 0.1 WT} cpdef (<) {0 rot 1 0.92 0 WT} cpdef (>) {180 rot 0 0 1 WT} cpdef } def % View as filamentous domino tiling /filaments { stdchr (A) {270 rot 1 0 0 WT} {i 1 and 1 eq} ccdef (V) {90 rot 0.5 1 1 WT} {i 1 and 1 eq} ccdef (<) {0 rot 1 0 0 WT} {j 1 and 1 eq} ccdef (>) {180 rot 0.5 1 1 WT} {j 1 and 1 eq} ccdef } def % View as matching /match { stdchr (A) {270 rot I} cpdef (V) {90 rot I} cpdef (<) {0 rot I} cpdef (>) {180 rot I} cpdef } def % View as domino tiling with lattice paths /paths { stdchr (A) {270 rot T down-p} cpdef (V) {90 rot T up-p} cpdef (<) {0 rot T straight-p} cpdef (>) {180 rot T} cpdef } def % View placement-probability data as gray scale /grays { stdchr (P) {4 {currentfile 1 string readhexstring pop 0 get 256 div dup 0 eq {pop} {prob 0 0 . 1 block 0 o} ifelse 90 rotate} repeat} cpdef (N) {4 {getword pop} repeat} cdef } def % View placement-probability data by writing numerators /nums { stdchr /Helvetica 1 selectfont stringwidth pop (---) stringwidth pop add blocksize exch div /fsize exch def /Helvetica fsize selectfont (N) {[-90 180 -90 180] {rotate getword dup (0) eq {pop} {0.5 block -0.35 fsize mul moveto cshow 0 0 . 1 block 0 o} ifelse} forall} cpdef (P) {4 {currentfile 1 string readhexstring pop pop} repeat} cdef } def % For viewing mazes /maze { stdchr (V) {270 rot 0 0 . I} codef (A) {90 rot 0 0 . I} codef (>) {0 rot 0 0 . I} codef (<) {180 rot 0 0 . I} codef } def /cshow {dup stringwidth pop -2 div 0 rmoveto show} def /rshow {dup stringwidth pop neg 0 rmoveto show} def /mazecage { % width height -1 block 1 block moveto 1 index 1 add block 0 rlineto dup neg block 0 exch rlineto stroke 1 index block 1 index neg block moveto 1 index 1 add neg block 0 rlineto -1 block 0 block lineto stroke /Times-Roman findfont 0.6 block scalefont setfont -0.3 block 0.2 block moveto (enter MIT) rshow exch -0.3 add block exch neg 0.3 add block moveto (get Ph.D.) show } def % Character coordinates are converted to page coordinates. % cartesian and hexagonal coordinates /block {blocksize mul} def /carpos {block exch block neg} bind def /hexpos {0.5 block mul exch r32 neg} bind def /pos {carpos} bind def % go to the position and reset the origin /org {gsave i j pos translate} def /rot {rotate} bind def /tilepath {-0.5 block -0.5 block moveto 2 block 0 rlineto 0 1 block rlineto -2 block 0 rlineto closepath} bind def /itilepath {-0.45 block -0.45 block moveto 1.90 block 0 rlineto 0 0.90 block rlineto -1.90 block 0 rlineto closepath} bind def /. {newpath 0.1 block 0 360 arc 0 setgray fill} def /o {newpath 0.1 block 0 360 arc gsave 1 setgray fill grestore 0 setgray stroke} def /. {newpath 0.1 block 0 360 arc gsave 0 setgray fill grestore 1 setgray stroke 0 setgray} def /node {newpath 0 0 0.1 block 0 360 arc gsave 0 setgray fill grestore} def /T {tilepath stroke} def /ST {tilepath gsave setgray fill grestore stroke} def /CT {tilepath gsave setrgbcolor fill grestore stroke} def /BT {tilepath 0 0 0 setrgbcolor fill itilepath setrgbcolor fill} def /WT {tilepath 1 1 1 setrgbcolor fill itilepath setrgbcolor fill} def /straight-p {-0.5 block 0 moveto 2 block 0 rlineto 1 setlinewidth stroke} def /up-p {0 0.5 block moveto 1 block -1 block rlineto 1 setlinewidth stroke} def /down-p {0 -0.5 block moveto 1 block 1 block rlineto 1 setlinewidth stroke} def /I {0 0 moveto 1 block 0 rlineto stroke} bind def /J {0 0 moveto 0.5 block 0.3 block lineto 1 block 0 lineto stroke} bind def /prob {0 0 moveto 0.3 block 0.3 block lineto 0.7 block 0.3 block lineto 1 block 0 lineto 0.7 block -0.3 block lineto 0.3 block -0.3 block lineto closepath neg 1 add setgray fill } def /r3 {3 sqrt mul block} def /r13 {1 3 sqrt div mul block} def /r32 {3 sqrt 2 div mul block} def /lozenge {0 1 r13 moveto 0.5 block -1 r32 rlineto -0.5 block -1 r32 rlineto -0.5 block 1 r32 rlineto closepath gsave setrgbcolor fill grestore} bind def /cliff {-0.5 block -0.5 r13 moveto 1 block 0 rlineto -0.5 block 0.5 r3 rlineto closepath 0 0.8 0 setrgbcolor fill 0 1 r13 moveto -0.5 block 0.5 r3 rlineto 1 block 0 rlineto closepath 0 0.6 0.8 setrgbcolor fill} bind def /cshow {dup stringwidth pop -2 div 0 rmoveto show} def /in {72 mul} def /title { /Times-Roman findfont 0.2 in scalefont setfont 4.25 in exch moveto cshow } def /getword {[{currentfile 1 string readstring pop 0 get dup 32 eq {pop exit} if} loop] dup length dup string 0 1 4 -1 roll 1 sub {1 index exch dup 4 index exch get put} for exch pop} def % View graphs (default) or matchings (vmatch) in vax format. % Support for various lattices % l4 square lattice % l6 hexagonal lattice % l8-4 square-octagonal lattice % l12-6-4 dodecagon-hexagon-square lattice % Use the phase command if the phase of the lattice in the file is different % than that which is programmed by default. /vax { /l4 {/pos {block exch block neg} bind def} def /l6 {/pos {1 index 1 index xor 1 and 3 -1 roll 1.5 mul exch 0.5 mul sub block neg exch s32 mul block exch} bind def} def /s3 3 sqrt def /l3+d {/xarr [[0 -1 0 1] [0 0 0 0] [0 1 0 -1] [0 0 0 0]] def /yarr [[0 0 0 0] [1 0 -1 0] [0 0 0 0] [-1 0 1 0]] def /pos {phasor xarr 2 index 3 and get 1 index 3 and get yarr 3 index 3 and get 2 index 3 and get 4 1 roll add block 3 1 roll exch 3 div add s3 mul block neg} def} def /fl2 {dup 0 lt {not -1 bitshift not} {-1 bitshift} ifelse} bind def /fl4 {dup 0 lt {not -2 bitshift not} {-2 bitshift} ifelse} bind def /s22 2 sqrt 2 div def /l8-4 { /pos {phasor dup 3 and dup mul 3 mod % (j mod 4 == 1 or 2) 2 index 1 and 2 mul 1 sub % (up or down) mul s22 mul 2 index 1 and add 2 index fl2 2 mul 1 s22 add mul add block neg 3 -1 roll pop exch dup fl2 1 s22 add mul exch 1 and s22 mul add block exch} bind def} def /s32 3 sqrt 2 div def /l12-6-4 {/xarr [[0 1 1 1] [0 0 0 1]] def /yarr [[0 2 0 2] [0 2 -1 3] [-1 3 0 2]] def /ycrr [0 1 2 0 0 2 1 0] def /pos {phasor dup dup fl4 sub s32 mul 1 index fl4 1.5 mul add xarr 2 index fl4 4 index fl2 xor 1 and get 2 index 3 and get 2 div add block 3 1 roll 1 index fl2 s32 3 2 div add mul 3 1 roll 7 and ycrr exch get yarr exch get exch 3 and get 2 div add block neg} bind def} def /phase {/pos [ 4 2 roll exch {4 1 roll add 3 1 roll add exch pos} bind {} forall ] cvx def} def /phase {/phasor [ 4 2 roll exch {4 1 roll add 3 1 roll add exch} {} forall ] cvx bind def} def 0 0 phase /vmatch { (A) {node cut-left cut-up bond-down cut-right} codef (V) {node cut-left bond-up cut-down cut-right} codef (<) {node cut-left cut-up cut-down bond-right} codef (>) {node bond-left cut-up cut-down cut-right} codef } def (X) {node bond-left bond-up bond-down bond-right} codef (A) {node bond-left cut-up bond-down bond-right} codef (V) {node bond-left bond-up cut-down bond-right} codef (<) {node cut-left bond-up bond-down bond-right} codef (>) {node bond-left bond-up bond-down cut-right} codef (I) {node cut-left bond-up bond-down cut-right} codef (=) {node bond-left cut-up cut-down bond-right} codef ( ) { cut-left cut-up cut-down cut-right incr} cdef (U) {node bond-left bond-up bond-down bond-right} codef (\\n) {] /prev-line exch def /prev-size j def [ /i i 1 add def /j 0 def} cdef (!) {] pop exit} cdef /! {/i 0 def /j 0 def [ {cdict currentfile read pop get exec} loop} bind def /bond-left {j 0 gt {{grestore i j pos moveto i j 1 sub pos lineto stroke org} if} if} def /cut-left {j 0 gt {pop} if} def /bond-right{true} def /cut-right {false} def /bond-down {true} def /cut-down {false} def /cut-up {} def /bond-up {i 0 gt {j prev-size lt {prev-line j get {grestore i j pos moveto i 1 sub j pos lineto stroke org} if} if} if} def } def % move the origin and set the blocksize so that % the picture is centered on the page /domcenter { % top left bottom right 0 setlinewidth /blocksize 1 def 3 index 1 sub 3 index 1 sub pos 3 index 1 add 3 index 1 add pos 3 index 2 index sub neg 6.5 in exch div 3 index 2 index sub 9 in exch div 1 index 1 index gt {exch} if pop /blocksize exch def 4 {pop} repeat 3 index 1 sub 3 index 1 sub pos 3 index 1 add 3 index 1 add pos 3 index 2 index add 2 div neg 4.25 in add 3 index 2 index add 2 div neg 5.5 in add translate 8 {pop} repeat } def %%EndProlog ")