diff --git a/contrib/psgraph/psgraph.catalog b/contrib/psgraph/psgraph.catalog index 2703a4a8757bbb9b3dc3d91bfadab1e25c3e40d4..4406e9e56c9bdac670ba2beb3b2b33c7795c7228 100644 --- a/contrib/psgraph/psgraph.catalog +++ b/contrib/psgraph/psgraph.catalog @@ -6,9 +6,13 @@ Description: Postscript commands that display a directed acyclic graph. Author: - Joseph Bates. Skef put the whole thing in the PSGRPAPH package and added -functionality which allows the user to specify EQ, EQUAL, or EQUALP as the -node equivalence function. Bill made all exported symbols have stars on them. + Joseph Bates. Skef put the whole thing in the PSGRPAPH package and +added functionality which allows the user to specify EQ, EQUAL, or +EQUALP as the node equivalence function. Bill made all exported +symbols have stars on them. Douglas Crosher fixed the hash table +usage, added the shrink :width option and the same-height optional +argument, and cleaned up the source reducing special variables usage +and adding declarations for CMUCL. Address: Carnegie-Mellon University @@ -22,12 +26,10 @@ Copyright Status: Public Domain. Files: - psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog + psgraph.lisp, psgraph.doc, psgraph.catalog How to Get: - The following unix command will copy the pertinent files into directory -<spec>. - cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec> + ftp://ftp2.cons.org/pub/languages/lisp/cmucl/src/contrib/psgraph/* Portability: Should run in any legal Common Lisp. Requires Postscript for printing. @@ -41,21 +43,4 @@ run through the output escaping any PS control characters. For example, if node labels contain parentheses, your output PS file will not print. Examples: - Skef Wholey submitted this as a reasonable example: - -;;; I use this in my compiler so I can look at code trees without -;;; crawling around them in the inspector. The postsript previewer -;;; groks the generated ps file, which is bitchin' marvy. - - (defun code-graph-to-file (s file &optional shrink insert) - (let ((psgraph:*fontname* "Times-Roman") - (psgraph:*fontsize* 8) - (psgraph:*second-fontname* "Times-BoldItalic") - (psgraph:*second-fontsize* 6) - (psgraph:*boxgray* "0") - (psgraph:*edgegray* "0") - (psgraph:*extra-x-spacing* 30)) - (with-open-file (*standard-output* file - :direction :output - :if-exists :supersede) - (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq)))) + See psgraph.doc diff --git a/contrib/psgraph/psgraph.doc b/contrib/psgraph/psgraph.doc index e7b17692d06d8a4714eb3ee0a3268ef9b1cff85d..0f8a43e79f5f8410f9f310bb2df59a3505b093d8 100644 --- a/contrib/psgraph/psgraph.doc +++ b/contrib/psgraph/psgraph.doc @@ -1,57 +1,61 @@ Here is a brief summary of how to use the PSgrapher. The PSgrapher is a set of Lisp routines that can be called to produce -Postscript commands to display a directed acyclic graph. It uses the same -basic algorithm as the ISI Grapher. It is slower than the ISI grapher, but -produces much prettier output than using Xdump to copy an ISI Grapher screen -image to a Postscript printer. It also allows arbitrary information to be -displayed with a node, and can print as many output pages as are necessary to -accomodate large graphs (subject to Postscript printer limits, typically one or -two thousand nodes). - -The PSgrapher is small enough and easy enough to use to be included in other -systems without pain. It is also free and not copyrighted. - -Copy the file /afs/cs/project/clisp/library/psgraph/psgraph.lisp to your -directory. It is written in Common Lisp, and has been tested on CMU Common -Lisp on RTs and Lucid on SUNs. All interfaces described below are exported -from the "PSGRAPH" package. - -There are several useful global variables that can be modified and one function -to be called. The variables affect the style of the printed image, the -function walks a graph and produces output. - -A graph is defined by a root node and a function for getting children of a -node. Nodes are named by Lisp objects, and these names are checked using a -user-supplied test function (defaults to EQUAL) for purposes of walking the -graph and topologically sorting it. Typically one uses atoms to name nodes, -for example in graphing an inheritence net one could use the class names as -node names. +Postscript commands to display a directed acyclic graph. It uses the +same basic algorithm as the ISI Grapher. It is slower than the ISI +grapher, but produces much prettier output than using Xdump to copy an +ISI Grapher screen image to a Postscript printer. It also allows +arbitrary information to be displayed with a node, and can print as +many output pages as are necessary to accomodate large graphs (subject +to Postscript printer limits, typically one or two thousand nodes). + +The PSgrapher is small enough and easy enough to use to be included in +other systems without pain. It is also free and not copyrighted. + +It is written in Common Lisp, and has been tested on CMU Common Lisp 18 +All interfaces described below are exported from the "PSGRAPH" package. + +There are several useful global variables that can be modified and one +function to be called. The variables affect the style of the printed +image, the function walks a graph and produces output. + +A graph is defined by a root node and a function for getting children +of a node. Nodes are named by Lisp objects, and these names are +checked using a user-supplied test function (defaults to EQUAL) for +purposes of walking the graph and topologically sorting it. Typically +one uses atoms to name nodes, for example in graphing an inheritence +net one could use the class names as node names. To produce a graph call the function: - (psgraph:psgraph root-node-name + (psgraph:psgraph output-stream + root-node-name child-function info-function &optional (shrink nil) &optional (insert nil) - &optional (test #'equal)) + &optional (test #'equal) + &optional (same-height nil)) -Root-node-name is a Lisp object naming the root of the graph (there must be -exactly one root). +Output-stream is the stream that the postscript is output to. + +Root-node-name is a Lisp object naming the root of the graph (there +must be exactly one root). Child-function takes a node name and returns a list of node names. -Info-function takes a node name and returns a list of strings. Each string -shows up as one line in the printed form of the node, with the first string -displayed in one font (determined by variables *fontname*, *fontsize*) and the -others in another font (determined by variables *second-fontname*, -*second-fontsize*). Typically the first string is just the name of the node, -eg, (string node-name). +Info-function takes a node name and returns a list of strings. Each +string shows up as one line in the printed form of the node, with the +first string displayed in one font (determined by variables +*fontname*, *fontsize*) and the others in another font (determined by +variables *second-fontname*, *second-fontsize*). Typically the first +string is just the name of the node, eg, (string node-name). -Shrink is a boolean. It defaults to nil, and in this case the graph -prints on as many pages as are needed to show the whole thing. If shrink -is t then the entire graph is squashed appropriately to fit on one page -of output. +Shrink may be NIL, T of :WIDTH. It defaults to nil, and in this case +the graph prints on as many pages as are needed to show the whole +thing. If shrink is T then the entire graph is squashed appropriately +to fit on one page of output. If shrink is :width then the width of +the graph is shrunk appropriately to fit across one page of output but +print on as many pages as necessary to show the full height of the graph. Insert is a boolean. It defaults to nil, and in this case the generated Postscript file contains commands to print the output. If insert is t @@ -61,14 +65,22 @@ in Scribe files, for example, and Scribe can decide when to print the page. Test is a function that return whether two nodes are the same. -After loading psgraph, one can play with the various global variables, all of -which have string values (except for the two font size variables). *fontname*, -*fontsize*, *second-fontname*, *second-fontsize* are as described above. They -default to "Helvetica" in 10 point and "Helvetica-Oblique" in 8 point, -respectively. *boxgray* and *boxkind* determine how the boxes around nodes -look. *boxkind* is either "fill" or "stroke", for solid or outline boxes, and -*boxgray* is "0" for solid black, "1" for solid white, or in between. These -default to ".2" and "stroke". +Same-height is a boolean. It defaults to Nil, and in this case the +height of the node no large that necessary. If same-height is T the +same height is used for all the nodes which can improve the balance of +tree graphs. + +-=- + +After loading psgraph, one can play with the various global variables, +all of which have string values (except for the two font size +variables). *fontname*, *fontsize*, *second-fontname*, +*second-fontsize* are as described above. They default to "Helvetica" +in 10 point and "Helvetica-Oblique" in 8 point, respectively. +*boxgray* and *boxkind* determine how the boxes around nodes look. +*boxkind* is either "fill" or "stroke", for solid or outline boxes, +and *boxgray* is "0" for solid black, "1" for solid white, or in +between. These default to ".2" and "stroke". Other variables: *max-psnodes* @@ -85,21 +97,16 @@ Other variables: *chunksize* -Psgraph sends its output to *standard-output*, so typically it is called -from within (with-open-file ....). For example, one might use it like this: +Psgraph sends its output to the output-stream, so typically it is +called from within (with-open-file ....). For example, one might use +it like this: - (load "psgraph.fasl") + (load "psgraph") (setf psgraph:*boxkind* "fill") (setf psgraph:*boxgray* ".8") (setf psgraph:*fontsize* 8) (setf psgraph:*second-fontsize* 6) - (defun graph (&optional (shrink t)) - (with-open-file (*standard-output* "g.ps" - :direction :output - :if-exists :supersede) - (psgraph:psgraph 'A #'children #'info shrink nil #'eq))) - (defun children (x) (cond ((eq x 'A) '(B C D)) ((member x '(B C D)) '(E F G)) @@ -109,6 +116,12 @@ from within (with-open-file ....). For example, one might use it like this: (defun info (x) (list (string x))) + (defun graph (&optional (shrink t)) + (with-open-file (output-stream "g.ps" + :direction :output + :if-exists :supersede) + (psgraph:psgraph output-stream 'A #'children #'info shrink nil #'eq))) + Another example: (defun code-graph-to-file (s file &optional shrink insert) @@ -119,7 +132,7 @@ Another example: (psgraph:*boxgray* "0") (psgraph:*edgegray* "0") (psgraph:*extra-x-spacing* 30)) - (with-open-file (*standard-output* file - :direction :output - :if-exists :supersede) + (with-open-file (output-stream file + :direction :output + :if-exists :supersede) (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq)))) diff --git a/contrib/psgraph/psgraph.lisp b/contrib/psgraph/psgraph.lisp index 09e37bbcf1871f09e96468e385606260f77bc3e4..057464aadfae1b8977ab90e699ebbbd4fbe83efd 100644 --- a/contrib/psgraph/psgraph.lisp +++ b/contrib/psgraph/psgraph.lisp @@ -1,33 +1,61 @@ -;;; -*- Mode: Lisp; Package: PSGRAPH; Log: psgraph.log -*- +;;; -*- Mode: Lisp; Package: PSGRAPH -*- ;;; -;;; PostScript DAG Grapher -- Joseph Bates, CMU CSD, March 1988 +;;; **************************************************************** +;;; PostScript DAG Grapher ***************************************** +;;; **************************************************************** +;;; Written by Joseph Bates, CMU CSD, March 1988. jbates+@cs.cmu.edu ;;; -;;; See psgraph.log for other modifiers. +;;; The PSGrapher is a set of Lisp routines that can be called to produce +;;; PostScript commands that display a directed acyclic graph. ;;; -(in-package "PSGRAPH") - -(export '(*max-psnodes* *extra-x-spacing* *extra-y-spacing* *fontname* - *fontsize* *second-fontname* *second-fontsize* *boxgray* *boxkind* - *edgewidth* *edgegray* *edgecap* *textgray* *pageheight* *pagewidth* - *boxradius* *boxedge* *chunksize* - - psgraph)) +;;; Modifications History: +;;; +;;; AUG 97 dtc Added declarations to help the CMUCL compiler. +;;; Only the *psnode-index* hash should use the user +;;; supplied hash test, all the others are internal. +;;; Make the output stream a required argument rather +;;; than sending output to *standard-output*. +;;; Add a shrink :width optional to scale the graph to +;;; fit across one page. +;;; Add optional same-height argument to allocate the same +;;; height for each node - can give nicer graphs. +;;; Misc. style changes: less use of special variables, etc. +;;; JAN 92 mkant Modified to be package compatible with CLtL2 lisps. +;;; JULY 90 mkant Fixed shrink mode so that it scales x and y +;;; axes uniformly (e.g., aspect ratio = 1). +;;; MAY 90 Chiles Made exported specials have stars. +;;; APR 90 Skef Now lives in PSGRAPH package (instead of USER, +;;; or *package*...) with user-tweakable stuff exported. +;;; Node equivalence function can now be specified as +;;; EQ, EQUAL, or EQUALP. +;;; DEC 88 Bates Modified to include optional insert parameter to psgraph. +;;; MAR 88 Bates File created. +;;; +(eval-when (compile load eval) + (defpackage "PSGRAPH" + (:use "COMMON-LISP") + (:export "*EXTRA-X-SPACING*" "*EXTRA-Y-SPACING*" "*FONTNAME*" + "*FONTSIZE*" "*SECOND-FONTNAME*" "*SECOND-FONTSIZE*" + "*BOXGRAY*" "*BOXKIND*" "*EDGEWIDTH*" "*EDGEGRAY*" + "*EDGECAP*" "*TEXTGRAY*" "*PAGEHEIGHT*" "*PAGEWIDTH*" + "*BOXRADIUS*" "*BOXEDGE*" "*CHUNKSIZE*" "PSGRAPH"))) +(in-package "PSGRAPH") (defstruct psnode name - info - children - parents - appears-in-top-sort - children-appear-in-top-sort - yvalue - height -) - -(defvar *max-psnodes* 5000) + (info '() :type list) + (children '() :type list) + (parents '() :type list) + (appears-in-top-sort nil :type (member nil t)) + (children-appear-in-top-sort nil :type (member nil t)) + (yvalue 0 :type fixnum) + (height 0 :type fixnum)) + +(declaim (fixnum *extra-x-spacing* *extra-y-spacing*)) (defvar *extra-x-spacing* 20) (defvar *extra-y-spacing* 6) +(declaim (fixnum *fontsize* *second-fontsize*)) (defvar *fontname* "Helvetica") (defvar *fontsize* 10) (defvar *second-fontname* "Helvetica-Oblique") @@ -38,469 +66,504 @@ (defvar *edgegray* ".2") ;; dark, but not solid black, lines (defvar *edgecap* "1") ;; round the line caps (defvar *textgray* "0") ;; solid black text +(declaim (fixnum *pageheight* *pagewidth*)) (defvar *pageheight* 720) (defvar *pagewidth* (+ (* 7 72) 36)) +(declaim (fixnum *boxradius* *boxedge*)) (defvar *boxradius* (floor *fontsize* 2)) (defvar *boxedge* (floor *fontsize* 4)) +(declaim (fixnum *chunksize*)) (defvar *chunksize* 400) -(defvar num-psnodes) -(defvar narray) -(defvar psnode-index) -(defvar child-function) -(defvar info-function) -(defvar top-sort) -(defvar maximum-y) -(defvar minimum-y) -(defvar rows) -(defvar y-offset) -(defvar psnodes-at-y) -(defvar ancestor-cache) - -(defun psgraph (root childf infof &optional (shrink nil) (insert nil) (test #'equal)) +(declaim (fixnum *num-psnodes*)) +(defvar *num-psnodes* 0) +(declaim (type (simple-array t (*)) *narray*)) +(defvar *narray*) +(defvar *psnode-index*) +(defvar *top-sort*) +(defvar *ancestor-cache*) + +(defun psgraph (stream root childf infof + &optional (shrink nil) (insert nil) (test #'equal) + (same-height nil)) + (declare (stream stream) + (function childf infof) + (type (or symbol function) test)) (unless (member test (list 'eq 'equal 'equalp #'eq #'equal #'equalp)) (error "Test must be a function suitable to hand to Make-Hash-Table.")) - (when insert (setf shrink t)) - (setq narray (make-array *max-psnodes*)) - (setq num-psnodes 0) - (setq psnode-index (make-hash-table :test test - :size 500 - :rehash-size 2.0)) - (setq child-function childf) - (setq info-function infof) - (setq ancestor-cache (make-hash-table :test test - :size 1000 - :rehash-size 2.0)) - - ;;; walk the graph computing node info - (walk-graph root) - (dotimes (index num-psnodes) - (setf (psnode-parents (aref narray index)) - (nreverse (psnode-parents (aref narray index)))) - (setf (psnode-children (aref narray index)) - (nreverse (psnode-children (aref narray index))))) - - ;;; topological sort the graph - (setq top-sort nil) - (top-sort-node 0) - (setq top-sort (nreverse top-sort)) - - ;;; declare this as a PostScript file - (format t "%!PS-Adobe-1.0~%") - - ;;; this is required for the Apple LaserWriter (it likes to know the page - ;;; ordering so that it can print pages upside down). It is best not to - ;;; confuse the LaserWriter when inserting things into a other documents. - (when (not insert) - (format t "%%Page: ? ?~%")) - - ;;; define global functions - (dolist (line '( - - "/max {2 copy lt {exch} if pop} def" - - "/min {2 copy gt {exch} if pop} def" - - "/inch {72 mul} def" - - "/drawbox" - " {/height exch def" - " /width exch def" - " /y exch def" - " /x exch def" - " gsave newpath" - " x y boxradius add moveto" - " x y height add x width add y height add boxradius arcto pop pop pop pop" - " x width add y height add x width add y boxradius arcto pop pop pop pop" - " x width add y x y boxradius arcto pop pop pop pop" - " x y x y height add boxradius arcto pop pop pop pop" - " boxgray setgray boxkind grestore" - " } def" - - "/printposter" - " {/rows exch def" - " /columns exch def" - " /bigpictureproc exch def" - " newpath" - " leftmargin botmargin moveto" - " 0 pageheight rlineto" - " pagewidth 0 rlineto" - " 0 pageheight neg rlineto" - " closepath clip" - " leftmargin botmargin translate" - " 0 1 rows 1 sub" - " {/rowcount exch def" - " 0 1 columns 1 sub" - " {/colcount exch def" - " gsave" - " pagewidth colcount mul neg" - " pageheight rowcount mul neg" - " translate" - " bigpictureproc" - " gsave showpage grestore" - " grestore" - " } for" - " } for" - " } def" - - )) (format t "~A~%" line)) - - ;;; declare arrays - (format t "/xarray ~D array def~%" num-psnodes) - (format t "/widtharray ~D array def~%" num-psnodes) - - ;;; define global settings - (format t "/leftmargin 36 def~%") - (format t "/botmargin 36 def~%") - (format t "/pagewidth ~D def~%" *pagewidth*) - (format t "/pageheight ~D def~%" *pageheight*) - (format t "/boxradius ~D def ~%" *boxradius*) - (format t "/boxedge ~D def ~%" *boxedge*) - (format t "/boxgray ~A def ~%" *boxgray*) - (format t "/boxkind {~A} def~%" *boxkind*) - - ;;; compute width and height of each node - (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*) - (dotimes (index num-psnodes) - (format t "widtharray ~D (~A) stringwidth pop put~%" - index - (car (psnode-info (aref narray index))))) - (format t "/~A findfont ~D scalefont setfont~%" - *second-fontname* *second-fontsize*) - (dotimes (index num-psnodes) - (format t "widtharray ~D get~%" index) - (dolist (info (cdr (psnode-info (aref narray index)))) - (format t "(~A) stringwidth pop max~%" info)) - (format t "~D add widtharray exch ~D exch put~%" - (* 2 *boxedge*) - index)) - (dotimes (index num-psnodes) - (setf (psnode-height (aref narray index)) - (+ (* 2 *boxedge*) - *extra-y-spacing* - *fontsize* - (* (- (length (psnode-info (aref narray index))) 1) - *second-fontsize*)))) - - ;;; compute x location of each node - (format t "xarray 0 0 put~%") - (dolist (index (cdr top-sort)) - (let ((parents (psnode-parents (aref narray index)))) - (format t "xarray ~D get widtharray ~D get add~%" - (car parents) (car parents)) - (dolist (parent (cdr parents)) - (format t "xarray ~D get widtharray ~D get add max~%" + (let ((maximum-y 0) + (minimum-y 0) + psnodes-at-y + (*narray* (make-array 5000 :element-type 'psnode)) + (*num-psnodes* 0) + (*psnode-index* + (make-hash-table :test test :size 500 :rehash-size 2.0)) + (*ancestor-cache* + (make-hash-table :test #'equal :size 1000 :rehash-size 2.0)) + (*top-sort* nil)) + (declare (fixnum maximum-y minimum-y)) + + (when insert (setf shrink t)) + + ;; walk the graph computing node info + (walk-graph root childf infof) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (let ((psnode (aref *narray* index))) + (setf (psnode-parents psnode) (nreverse (psnode-parents psnode))) + (setf (psnode-children psnode) (nreverse (psnode-children psnode))))) + + ;; topological sort the graph + (top-sort-node 0) + (setq *top-sort* (nreverse *top-sort*)) + + ;; declare this as a PostScript file + (format stream "%!PS-Adobe-1.0~%") + + ;; this is required for the Apple LaserWriter (it likes to know + ;; the page ordering so that it can print pages upside down). It + ;; is best not to confuse the LaserWriter when inserting things + ;; into a other documents. + (when (not insert) + (format stream "%%Page: ? ?~%")) + + ;; define global functions + (format stream + "/max {2 copy lt {exch} if pop} def~@ + /min {2 copy gt {exch} if pop} def~@ + /inch {72 mul} def~@ + /drawbox~@ + {/height exch def~@ + /width exch def~@ + /y exch def~@ + /x exch def~@ + gsave newpath~@ + x y boxradius add moveto~@ + x y height add x width add y height add boxradius arcto pop pop pop pop~@ + x width add y height add x width add y boxradius arcto pop pop pop pop~@ + x width add y x y boxradius arcto pop pop pop pop~@ + x y x y height add boxradius arcto pop pop pop pop~@ + boxgray setgray boxkind grestore~@ + } def~%") + + ;; declare arrays + (format stream "/xarray ~D array def~%" *num-psnodes*) + (format stream "/widtharray ~D array def~%" *num-psnodes*) + + ;; define global settings + (format stream "/leftmargin 36 def~@ + /botmargin 36 def~%") + (format stream "/pagewidth ~D def~%" *pagewidth*) + (format stream "/pageheight ~D def~%" *pageheight*) + (format stream "/boxradius ~D def ~%" *boxradius*) + (format stream "/boxedge ~D def ~%" *boxedge*) + (format stream "/boxgray ~A def ~%" *boxgray*) + (format stream "/boxkind {~A} def~%" *boxkind*) + + ;; compute width of each node + (format stream "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (format stream "widtharray ~D (~A) stringwidth pop put~%" + index (car (psnode-info (aref *narray* index))))) + (format stream "/~A findfont ~D scalefont setfont~%" + *second-fontname* *second-fontsize*) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (format stream "widtharray ~D get~%" index) + (dolist (info (cdr (psnode-info (aref *narray* index)))) + (format stream "(~A) stringwidth pop max~%" info)) + (format stream "~D add widtharray exch ~D exch put~%" + (* 2 *boxedge*) index)) + ;; compute x location of each node + (format stream "xarray 0 0 put~%") + (dolist (index (cdr *top-sort*)) + (let ((parents (psnode-parents (aref *narray* index)))) + (format stream "xarray ~D get widtharray ~D get add~%" + (car parents) (car parents)) + (dolist (parent (cdr parents)) + (format stream "xarray ~D get widtharray ~D get add max~%" parent parent)) - (format t "~D add xarray exch ~D exch put~%" *extra-x-spacing* index))) - - ;;; compute maximum x used - (format t "/maximum-x 0~%") - (dotimes (index num-psnodes) - (format t "xarray ~D get widtharray ~D get add max~%" - index index)) - (format t "def~%") - - ;;; compute y location of each node and maximum and minimum y used - (setq maximum-y 0) - (setq minimum-y 0) - (setq psnodes-at-y (make-hash-table :test test - :size (* num-psnodes *fontsize*) - :rehash-size 2.0)) - (let ((currenty 0)) - (dolist (index (reverse top-sort)) - (let (desired-y) - (cond ((null (psnode-children (aref narray index))) - (setf desired-y currenty) - (setf currenty (+ currenty (psnode-height - (aref narray index))))) - (t - (let ((children (psnode-children (aref narray index))) - (ysum 0)) - (dolist (child children) - (setf ysum (+ ysum (psnode-yvalue (aref narray child))))) - (setq desired-y (floor ysum (length children)))))) - - ;;; We may not be able to put the node at the desired y. - ;;; If there is another node that overlaps in the y direction - ;;; and that node is neither a parent* nor child* (hence its x - ;;; location may overlap this one) then we have to choose - ;;; another y value -- we choose the nearest (up or down) - ;;; location so that there is no possible overlap in y or x. - (let ((height (psnode-height (aref narray index))) - (related (make-hash-table :test test - :size (+ 50 num-psnodes) - :rehash-size 2.0)) - collision - upward-bot - upward-top - downward-bot - downward-top) - (setq upward-bot desired-y) - (setq upward-top upward-bot) - (setq downward-top (- (+ desired-y height) 1)) - (setq downward-bot downward-top) - (loop - ;;; check upward-top for collision - (setq collision nil) - (dolist (n (gethash upward-top psnodes-at-y)) - (let ((r (gethash n related))) - (when (null r) - (setf r (related-classes n index)) - (setf (gethash n related) r)) - (when (eql r 'no) - (setq collision t) - (return)))) - - ;;; if no collision and big enough space then we win - (incf upward-top) - (when (and (not collision) (= (- upward-top upward-bot) height)) - (setf desired-y upward-bot) - (return)) - - (when collision - (setf upward-bot upward-top)) - - ;;; check downward-bot for collision - (setq collision nil) - (dolist (n (gethash downward-bot psnodes-at-y)) - (let ((r (gethash n related))) - (when (null r) - (setf r (related-classes n index)) - (setf (gethash n related) r)) - (when (eql r 'no) - (setq collision t) - (return)))) - - ;;; if no collision and big enough space then we win - (decf downward-bot) - (when (and (not collision) (= (- downward-top downward-bot) height)) - (setf desired-y (+ 1 downward-bot)) - (return)) + (format stream "~D add xarray exch ~D exch put~%" + *extra-x-spacing* index))) + ;; compute maximum x used + (format stream "/maximum-x 0~@ + 0 1 ~d~@ + {/i exch def~@ + xarray i get widtharray i get add max~@ + } for~@ + def~%" + (1- *num-psnodes*)) + + ;; compute height of each node, and the maximum height. + (let ((max-height 0)) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (let* ((psnode (aref *narray* index)) + (height (+ (* 2 *boxedge*) *extra-y-spacing* *fontsize* + (* (- (length (psnode-info psnode)) 1) + *second-fontsize*)))) + (setf (psnode-height psnode) height) + (when (> height max-height) + (setf max-height height)))) + + ;; compute y location of each node and maximum and minimum y used + (setq psnodes-at-y (make-hash-table :test #'eql + :size (* *num-psnodes* *fontsize*) + :rehash-size 2.0)) + (let ((currenty 0)) + (declare (fixnum currenty)) + (dolist (index (reverse *top-sort*)) + (let ((desired-y 0)) + (declare (fixnum desired-y)) + (cond ((null (psnode-children (aref *narray* index))) + (setf desired-y currenty) + (incf currenty (if same-height + max-height + (psnode-height (aref *narray* index))))) + (t + (let ((children (psnode-children (aref *narray* index))) + (ysum 0)) + (declare (fixnum ysum)) + (dolist (child children) + (incf ysum (psnode-yvalue (aref *narray* child)))) + (setq desired-y (floor ysum (length children)))))) + ;; We may not be able to put the node at the desired y. If + ;; there is another node that overlaps in the y direction + ;; and that node is neither a parent* nor child* (hence its + ;; x location may overlap this one) then we have to choose + ;; another y value -- we choose the nearest (up or down) + ;; location so that there is no possible overlap in y or x. + (let* ((height (if same-height + max-height + (psnode-height (aref *narray* index)))) + (related (make-hash-table :test #'equal + :size (+ 50 *num-psnodes*) + :rehash-size 2.0)) + collision + (upward-bot desired-y) + (upward-top upward-bot) + (downward-top (- (+ desired-y height) 1)) + (downward-bot downward-top)) + (declare (fixnum upward-bot upward-top + downward-top downward-bot)) + (loop + ;; check upward-top for collision + (setq collision nil) + (dolist (n (gethash upward-top psnodes-at-y)) + (let ((r (gethash n related))) + (when (null r) + (setf r (related-classes n index)) + (setf (gethash n related) r)) + (when (eql r 'no) + (setq collision t) + (return)))) - (when collision - (setf downward-top downward-bot)) - ) - ;;; add our name to psnodes-at-y table - (dotimes (i height) - (push index (gethash (+ i desired-y) psnodes-at-y))) - - (setf (psnode-yvalue (aref narray index)) desired-y) - ) - - (setf minimum-y (min minimum-y (psnode-yvalue (aref narray index)))) - (setf maximum-y - (max maximum-y (+ (psnode-yvalue (aref narray index)) - (psnode-height (aref narray index)))))))) - - ;;; compute y-offset to center graph vertically - (setq rows (ceiling (- maximum-y minimum-y) *pageheight*)) - (setq y-offset (- (floor (- (* rows *pageheight*) (- maximum-y minimum-y)) 2) - minimum-y)) - (when shrink (setq y-offset (- 0 minimum-y))) - - ;;; create dictionary big enough to hold all the - ;;; procedures defined below and make it a current dictionary - (format t "~D dict begin~%" - (+ (* 4 (+ num-psnodes (ceiling num-psnodes *chunksize*))) 50)) - - ;;; define procedures to display the background box for each node - (dotimes (index num-psnodes) - (format t "/box~D {~%" index) - (format t "xarray ~D get ~D widtharray ~D get ~D drawbox~%" - index - (+ y-offset - (psnode-yvalue (aref narray index)) - (floor *extra-y-spacing* 2)) - index - (- (psnode-height (aref narray index)) *extra-y-spacing*)) - (format t "} def~%")) - - ;;; define procedures to display the text info for each node - (dotimes (index num-psnodes) - (let ((yvalue (+ y-offset - (floor *extra-y-spacing* 2) - (floor *fontsize* 5) - *boxedge* - (psnode-yvalue (aref narray index)) - (* *second-fontsize* - (- (length (psnode-info (aref narray index))) 1))))) - (format t "/text~D {xarray ~D get boxedge add ~D moveto (~A) show} def~%" - index - index - yvalue - (car (psnode-info (aref narray index)))) - (when (not (null (cdr (psnode-info (aref narray index))))) - (format t "/secondtext~D {~%" index) - (dolist (info (cdr (psnode-info (aref narray index)))) + ;; if no collision and big enough space then we win + (incf upward-top) + (when (and (not collision) (= (- upward-top upward-bot) height)) + (setf desired-y upward-bot) + (return)) + + (when collision + (setf upward-bot upward-top)) + + ;; check downward-bot for collision + (setq collision nil) + (dolist (n (gethash downward-bot psnodes-at-y)) + (let ((r (gethash n related))) + (when (null r) + (setf r (related-classes n index)) + (setf (gethash n related) r)) + (when (eql r 'no) + (setq collision t) + (return)))) + + ;; if no collision and big enough space then we win + (decf downward-bot) + (when (and (not collision) + (= (- downward-top downward-bot) height)) + (setf desired-y (+ 1 downward-bot)) + (return)) + + (when collision + (setf downward-top downward-bot))) + + ;; add our name to psnodes-at-y table + (dotimes (i height) + (declare (fixnum i)) + (push index (gethash (+ i desired-y) psnodes-at-y))) + + (setf (psnode-yvalue (aref *narray* index)) desired-y)) + + (setf minimum-y (min minimum-y + (psnode-yvalue (aref *narray* index)))) + (setf maximum-y + (max maximum-y (+ (psnode-yvalue (aref *narray* index)) + (if same-height + max-height + (psnode-height (aref *narray* index))))))))) + (when same-height + ;; Centre nodes vertically within the allocated max-height. + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (let* ((psnode (aref *narray* index)) + (height (psnode-height psnode))) + (incf (psnode-yvalue psnode) + (- (floor max-height 2) (floor height 2))))))) + + ;; compute y-offset to center graph vertically + (let* ((rows (ceiling (- maximum-y minimum-y) *pageheight*)) + (y-offset + (if shrink + (- 0 minimum-y) + (- (floor (- (the fixnum (* rows *pageheight*)) + (- maximum-y minimum-y)) 2) + minimum-y)))) + (declare (fixnum rows y-offset)) + + ;; create dictionary big enough to hold all the procedures + ;; defined below and make it a current dictionary + (format stream "~D dict begin~%" + (+ (* 4 (+ *num-psnodes* (ceiling *num-psnodes* + *chunksize*))) 50)) + + ;; define procedures to display the background box for each node + (dotimes (index *num-psnodes*) + (format stream "/box~D {~%" index) + (format stream "xarray ~D get ~D widtharray ~D get ~D drawbox~%" + index + (+ y-offset (psnode-yvalue (aref *narray* index)) + (floor *extra-y-spacing* 2)) + index + (- (psnode-height (aref *narray* index)) *extra-y-spacing*)) + (format stream "} def~%")) + + ;; define procedures to display the text info for each node + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (let ((yvalue (+ y-offset (floor *extra-y-spacing* 2) + (floor *fontsize* 5) *boxedge* + (psnode-yvalue (aref *narray* index)) + (the fixnum + (* *second-fontsize* + (- (length (psnode-info + (aref *narray* index))) 1)))))) + (declare (fixnum yvalue)) + (format stream "/text~D {xarray ~D get boxedge add ~ + ~D moveto (~A) show} def~%" + index index yvalue (car (psnode-info (aref *narray* index)))) + (when (not (null (cdr (psnode-info (aref *narray* index))))) + (format stream "/secondtext~D {~%" index) + (dolist (info (cdr (psnode-info (aref *narray* index)))) (setq yvalue (- yvalue *second-fontsize*)) - (format t "xarray ~D get boxedge add ~D moveto (~A) show~%" - index - yvalue - info)) - (format t "} def~%")))) - - ;;; define procedures to display the edges leading into each node - (dotimes (index num-psnodes) - (format t "/edge~D {newpath~%" index) - (dolist (parent (psnode-parents (aref narray index))) - (format t "xarray ~D get widtharray ~D get add ~D moveto~%" - parent - parent - (+ (psnode-yvalue (aref narray parent)) - (floor (psnode-height (aref narray parent)) 2) + (format stream "xarray ~D get boxedge add ~D moveto (~A) show~%" + index yvalue info)) + (format stream "} def~%")))) + + ;; define procedures to display the edges leading into each node + (dotimes (index *num-psnodes*) + (format stream "/edge~D {newpath~%" index) + (dolist (parent (psnode-parents (aref *narray* index))) + (format stream "xarray ~D get widtharray ~D get add ~D moveto~%" + parent parent + (+ (psnode-yvalue (aref *narray* parent)) + (floor (psnode-height (aref *narray* parent)) 2) y-offset)) - (format t "xarray ~D get ~D lineto~%" - index - (+ (psnode-yvalue (aref narray index)) - (floor (psnode-height (aref narray index)) 2) - y-offset))) - (format t "stroke } def~%")) - - ;;; Define procedures to display chunks of boxes, text, and edges. - ;;; We limit each chunk to at most *chunksize* calls, to avoid overflowing - ;;; the Postscript operand stack. - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/boxchunk~D {~%" (floor index *chunksize*))) - (format t "box~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/textchunk~D {~%" (floor index *chunksize*))) - (format t "text~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/secondtextchunk~D {~%" (floor index *chunksize*))) - (when (not (null (cdr (psnode-info (aref narray index))))) - (format t "secondtext~D~%" index)) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - (dotimes (index num-psnodes) - (when (eql (mod index *chunksize*) 0) - (format t "/edgechunk~D {~%" (floor index *chunksize*))) - (format t "edge~D~%" index) - (when (or (eql (mod index *chunksize*) (- *chunksize* 1)) - (eql index (- num-psnodes 1))) - (format t "} def~%"))) - - ;;; Define procedure to display entire graph. - ;;; First do the boxes, then the edges, then the text. - (format t "/drawgraph { gsave~%") - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "boxchunk~D~%" i)) - (format t "~A setlinewidth~%" *edgewidth*) - (format t "~A setlinecap~%" *edgecap*) - (format t "~A setgray~%" *edgegray*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "edgechunk~D~%" i)) - (format t "~A setgray~%" *textgray*) - (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "textchunk~D~%" i)) - (format t "/~A findfont ~D scalefont setfont~%" *second-fontname* *second-fontsize*) - (dotimes (i (ceiling num-psnodes *chunksize*)) - (format t "secondtextchunk~D~%" i)) - (format t "grestore } def~%") - - ;;; show the virtual page in as many actual pages as needed - (cond (shrink - ;;; shrink the output to fit on one page - (format t "leftmargin botmargin translate~%") - (format t "pagewidth dup maximum-x max div pageheight dup ~D max ~ - div min dup scale~%" - (- maximum-y minimum-y)) - (if insert - (format t "drawgraph end~%") - (format t "drawgraph showpage end~%"))) - (t - (format t "{drawgraph} maximum-x pagewidth div ceiling ~ - ~D printposter end~%" - rows))) - -) - - -(defun walk-graph (root) - (when (eql num-psnodes *max-psnodes*) - (error "More than ~D nodes in graph. Graphing aborted.")) - (let ((root-index num-psnodes) - (child-names (apply child-function (list root)))) - (incf num-psnodes) - (setf (gethash root psnode-index) root-index) - (setf (aref narray root-index) (make-psnode)) - (setf (psnode-name (aref narray root-index)) root) - (setf (psnode-info (aref narray root-index)) - (apply info-function (list root))) - (setf (psnode-children (aref narray root-index)) nil) - (setf (psnode-parents (aref narray root-index)) nil) - (setf (psnode-appears-in-top-sort (aref narray root-index)) nil) - (setf (psnode-children-appear-in-top-sort (aref narray root-index)) nil) + (format stream "xarray ~D get ~D lineto~%" + index + (+ (psnode-yvalue (aref *narray* index)) + (floor (psnode-height (aref *narray* index)) 2) + y-offset))) + (format stream "stroke } def~%")) + + ;; Define procedures to display chunks of boxes, text, and + ;; edges. We limit each chunk to at most *chunksize* calls, to + ;; avoid overflowing the Postscript operand stack. + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (when (zerop (mod index *chunksize*)) + (format stream "/boxchunk~D {~%" (floor index *chunksize*))) + (format stream "box~D~%" index) + (when (or (= (mod index *chunksize*) (- *chunksize* 1)) + (= index (- *num-psnodes* 1))) + (format stream "} def~%"))) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (when (zerop (mod index *chunksize*)) + (format stream "/textchunk~D {~%" (floor index *chunksize*))) + (format stream "text~D~%" index) + (when (or (= (mod index *chunksize*) (- *chunksize* 1)) + (= index (- *num-psnodes* 1))) + (format stream "} def~%"))) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (when (zerop (mod index *chunksize*)) + (format stream "/secondtextchunk~D {~%" (floor index *chunksize*))) + (when (cdr (psnode-info (aref *narray* index))) + (format stream "secondtext~D~%" index)) + (when (or (= (mod index *chunksize*) (- *chunksize* 1)) + (= index (- *num-psnodes* 1))) + (format stream "} def~%"))) + (dotimes (index *num-psnodes*) + (declare (fixnum index)) + (when (zerop (mod index *chunksize*)) + (format stream "/edgechunk~D {~%" (floor index *chunksize*))) + (format stream "edge~D~%" index) + (when (or (= (mod index *chunksize*) (- *chunksize* 1)) + (= index (- *num-psnodes* 1))) + (format stream "} def~%"))) + + ;; Define procedure to display entire graph. First do the + ;; boxes, then the edges, then the text. + (format stream "/drawgraph { gsave~%") + (dotimes (i (ceiling *num-psnodes* *chunksize*)) + (declare (fixnum i)) + (format stream "boxchunk~D~%" i)) + (format stream "~A setlinewidth~%" *edgewidth*) + (format stream "~A setlinecap~%" *edgecap*) + (format stream "~A setgray~%" *edgegray*) + (dotimes (i (ceiling *num-psnodes* *chunksize*)) + (declare (fixnum i)) + (format stream "edgechunk~D~%" i)) + (format stream "~A setgray~%" *textgray*) + (format stream "/~A findfont ~D scalefont setfont~%" + *fontname* *fontsize*) + (dotimes (i (ceiling *num-psnodes* *chunksize*)) + (declare (fixnum i)) + (format stream "textchunk~D~%" i)) + (format stream "/~A findfont ~D scalefont setfont~%" + *second-fontname* *second-fontsize*) + (dotimes (i (ceiling *num-psnodes* *chunksize*)) + (declare (fixnum i)) + (format stream "secondtextchunk~D~%" i)) + (format stream "grestore } def~%") + + ;; show the virtual page in as many actual pages as needed + (cond ((eq shrink :width) + ;; shrink the width to fit on a page. + (format stream + "newpath~@ + leftmargin botmargin moveto~@ + 0 pageheight rlineto~@ + pagewidth 0 rlineto~@ + 0 pageheight neg rlineto~@ + closepath clip~@ + leftmargin botmargin translate~@ + 0 1 ~d~@ + {/rowcount exch def~@ + gsave~@ + 0 pageheight rowcount mul neg translate~@ + pagewidth dup maximum-x max div dup 1 scale~@ + drawgraph~@ + 0.5 1 scale~@ + gsave showpage grestore~@ + grestore~@ + } for~@ + end~%" + (1- rows))) + (shrink + ;; shrink the output to fit on one page + (format stream "leftmargin botmargin translate~@ + pagewidth dup maximum-x max div ~ + pageheight dup ~D max div min dup scale~%" + (- maximum-y minimum-y)) + (if insert + (format stream "drawgraph end~%") + (format stream "drawgraph showpage end~%"))) + (t + (format stream + "/printposter~@ + {/rows exch def~@ + /columns exch def~@ + newpath~@ + leftmargin botmargin moveto~@ + 0 pageheight rlineto~@ + pagewidth 0 rlineto~@ + 0 pageheight neg rlineto~@ + closepath clip~@ + leftmargin botmargin translate~@ + 0 1 rows 1 sub~@ + {/rowcount exch def~@ + 0 1 columns 1 sub~@ + {/colcount exch def~@ + gsave~@ + pagewidth colcount mul neg~@ + pageheight rowcount mul neg~@ + translate~@ + drawgraph~@ + gsave showpage grestore~@ + grestore~@ + } for~@ + } for~@ + } def~%") + (format stream "maximum-x pagewidth div ceiling ~ + ~D printposter end~%" + rows)))))) + +(defun walk-graph (root child-function info-function) + (declare (function child-function info-function)) + (let ((root-index *num-psnodes*) + (child-names (funcall child-function root)) + (psnode (make-psnode :name root :info (funcall info-function root)))) + (incf *num-psnodes*) + (setf (gethash root *psnode-index*) root-index) + ;; Grow *narray* if necessary. + (when (>= root-index (length *narray*)) + (setf *narray* (adjust-array *narray* (ceiling (* *num-psnodes* 1.5)) + :element-type t))) + (setf (aref *narray* root-index) psnode) (dolist (child child-names) - (let ((child-index (gethash child psnode-index))) - (cond (child-index - (push child-index - (psnode-children (aref narray root-index))) - (push root-index - (psnode-parents (aref narray child-index)))) - (t - (let ((child-index (walk-graph child))) - (push child-index - (psnode-children (aref narray root-index))) - (push root-index - (psnode-parents (aref narray child-index)))))))) - root-index) -) - -(defun top-sort-node (index) - (when (not (psnode-appears-in-top-sort (aref narray index))) - - ;;; make sure the parents are processed - (dolist (parent (psnode-parents (aref narray index))) - (top-sort-parent parent)) - - ;;; add this node to top-sort - (push index top-sort) - (setf (psnode-appears-in-top-sort (aref narray index)) t)) - - (when (not (psnode-children-appear-in-top-sort (aref narray index))) - (dolist (child (psnode-children (aref narray index))) - (top-sort-node child)) - (setf (psnode-children-appear-in-top-sort (aref narray index)) t)) -) + (let ((child-index (gethash child *psnode-index*))) + (cond (child-index + (push child-index (psnode-children psnode)) + (push root-index (psnode-parents (aref *narray* child-index)))) + (t + (let ((child-index + (walk-graph child child-function info-function))) + (push child-index (psnode-children psnode)) + (push root-index + (psnode-parents (aref *narray* child-index)))))))) + root-index)) +(defun top-sort-node (index) + (let ((psnode (aref *narray* index))) + (unless (psnode-appears-in-top-sort psnode) + ;; make sure the parents are processed + (dolist (parent (psnode-parents psnode)) + (top-sort-parent parent)) + ;; add this node to *top-sort* + (push index *top-sort*) + (setf (psnode-appears-in-top-sort psnode) t)) + (unless (psnode-children-appear-in-top-sort psnode) + (dolist (child (psnode-children psnode)) + (top-sort-node child)) + (setf (psnode-children-appear-in-top-sort psnode) t)))) + (defun top-sort-parent (index) - (when (not (psnode-appears-in-top-sort (aref narray index))) - - ;;; make sure the parents are processed - (dolist (parent (psnode-parents (aref narray index))) - (top-sort-parent parent)) + (let ((psnode (aref *narray* index))) + (unless (psnode-appears-in-top-sort psnode) + ;; make sure the parents are processed + (dolist (parent (psnode-parents psnode)) + (top-sort-parent parent)) + ;; add this node to *top-sort* + (push index *top-sort*) + (setf (psnode-appears-in-top-sort psnode) t)))) - ;;; add this node to top-sort - (push index top-sort) - (setf (psnode-appears-in-top-sort (aref narray index)) t)) -) (defun related-classes (x y) (cond ((ancestor x y) 'yes) ((ancestor y x) 'yes) - (t 'no)) -) + (t 'no))) (defun ancestor (x y) - (let ((cached-value (gethash (list x y) ancestor-cache))) + (let ((cached-value (gethash (list x y) *ancestor-cache*))) (cond (cached-value (car cached-value)) (t - (setq cached-value - (cond ((equal x y) t) - (t - (some #'(lambda (child) (ancestor child y)) - (psnode-children (aref narray x)))))) - (setf (gethash (list x y) ancestor-cache) (list cached-value)) - cached-value))) -) + (setq cached-value + (if (equal x y) + t + (some #'(lambda (child) (ancestor child y)) + (psnode-children (aref *narray* x))))) + (setf (gethash (list x y) *ancestor-cache*) (list cached-value)) + cached-value)))) diff --git a/contrib/psgraph/psgraph.log b/contrib/psgraph/psgraph.log deleted file mode 100644 index 2214c46483006730ea5c185b074b31324f2678ef..0000000000000000000000000000000000000000 --- a/contrib/psgraph/psgraph.log +++ /dev/null @@ -1,18 +0,0 @@ -/usr1/chiles/work/psgraph.lisp, Jul-90 10:59:13, Edit by Mkant. - Fixed shrink mode so that it scales x and y axes uniformly (e.g., aspect - ratio = 1). - -/usr1/chiles/work/psgraph.lisp, 01-May-90 10:59:13, Edit by Chiles. - Made exported specials have stars. - -/usr1/chiles/work/psgraph.lisp, APR 90, Edit by Skef Wholey. - ;;; -- Now lives in the PSGRAPH package (instead of USER, or *package*...) - ;;; with user-tweakable stuff exported. - ;;; -- Node equivalence function can now be specified as EQ, EQUAL, - ;;; or EQUALP. - -/usr1/chiles/work/psgraph.lisp, DEC 88, Edit by Joseph Bates - Modified to include optional insert parameter to psgraph. - -/usr1/chiles/work/psgraph.lisp, MAR 88, Edit by Joseph Bates - File created.