diff options
Diffstat (limited to 'grapheps.scm')
| -rw-r--r-- | grapheps.scm | 617 |
1 files changed, 617 insertions, 0 deletions
diff --git a/grapheps.scm b/grapheps.scm new file mode 100644 index 0000000..0f11a6d --- /dev/null +++ b/grapheps.scm @@ -0,0 +1,617 @@ +;;;; "grapheps.scm", Create PostScript Graphs +;;; Copyright (C) 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'array) +(require 'array-for-each) +(require 'line-i/o) +(require 'color) +(require 'resene) +(require 'saturate) +(require 'filename) + +;;@code{(require 'eps-graph)} +;; +;;@noindent +;;This is a graphing package creating encapsulated-PostScript files. +;;Its motivations and design choice are described in +;;@url{http://swissnet.ai.mit.edu/~jaffer/Docupage/grapheps} +;; +;;@noindent +;;A dataset to be plotted is taken from a 2-dimensional array. +;;Corresponding coordinates are in rows. Coordinates from any +;;pair of columns can be plotted. + +;;; String append which accepts numbers, symbols, vectors, and lists. +(define (scheme->ps . args) + (apply string-append + (map (lambda (arg) + (cond ((number? arg) (number->string arg)) + ((symbol? arg) (symbol->string arg)) + ((or (vector? arg) (list? arg)) + (string-append + "[ " + (apply string-append + (map (lambda (x) (scheme->ps x " ")) + (if (vector? arg) (vector->list arg) arg))) + "]")) + (else arg))) + args))) + +;;; Capture for %%Title +(define *plot-title* #f) + +;; Remember arrays so each is output only once. +(define *plot-arrays* '()) + +;;@args filename.eps size elt1 ... +;;@1 should be a string naming an output file to be created. @2 +;;should be an exact integer, a list of two exact integers, or #f. +;;@3, ... are values returned by graphing primitives described here. +;; +;;@0 creates an @dfn{Encapsulated-PostScript} file named @1 containing +;;graphs as directed by the @3, ... arguments. +;; +;;The size of the graph is determined by the @2 argument. If a list +;;of two integers, they specify the width and height. If one integer, +;;then that integer is the width and the height is 3/4 of the width. +;;If #f, the graph will be 800 by 600. +(define (create-postscript-graph filename size . args) + (define xsize (cond ((pair? size) (car size)) + ((number? size) size) + (else 800))) + (let ((ysize (if (and (pair? size) (pair? (cdr size))) + (cadr size) + (quotient (* 3 xsize) 4)))) + (cond ((provided? 'inexact) + (set! xsize (inexact->exact (round xsize))) + (set! ysize (inexact->exact (round ysize))))) + (call-with-output-file filename + (lambda (oprt) + (define (write-lines lines) + (for-each (lambda (line) (if (list? line) + (write-lines line) + (write-line line oprt))) + lines)) + (write-line "%!PS-Adobe-3.0 EPSF-3.0" oprt) + (write-line (scheme->ps "%%BoundingBox: 0 0 " xsize " " ysize) oprt) + (write-line (scheme->ps "%%Title: " (or *plot-title* filename)) oprt) + (call-with-input-file (in-vicinity (library-vicinity) "grapheps.ps") + (lambda (iprt) + (do ((line (read-line iprt) (read-line iprt))) + ((eof-object? line)) + (write-line line oprt)))) + (for-each (lambda (pair) (write-array-def (cdr pair) (car pair) oprt)) + *plot-arrays*) + (write-lines args) + (newline oprt) + (write-line "grestore" oprt) + (write-line "end" oprt) + (write-line "showpage" oprt))) + (set! *plot-title* #f) + (set! *plot-arrays* '()))) + +(define (write-array-def name array oprt) + (define row-length (+ 1 (cadadr (array-shape array)))) + (define idx 0) + (set! idx row-length) + (write-line (scheme->ps "/" name) oprt) + (write-line "[" oprt) + (display " [" oprt) + (array-for-each + (lambda (elt) + (cond ((zero? idx) + (write-line "]" oprt) + (display " [" oprt))) + (display (scheme->ps " " elt) oprt) + (set! idx (modulo (+ 1 idx) row-length))) + array) + (write-line "]" oprt) + (write-line "] def" oprt)) + +;;; Arrays are named and cached in *plot-arrays*. +(define (import-array array) + (cond ((assq array *plot-arrays*) => cdr) + (else + (let ((name (gentemp))) + (set! *plot-arrays* (cons (cons array name) *plot-arrays*)) + name)))) + +;;@noindent +;;These graphing procedures should be called as arguments to +;;@code{create-postscript-graph}. The order of these arguments is +;;significant; PostScript graphics state is affected serially from the +;;first @var{elt} argument to the last. + +;;@body +;;Pushes a rectangle for the whole encapsulated page onto the +;;PostScript stack. This pushed rectangle is an implicit argument to +;;@code{partition-page} or @code{setup-plot}. +(define (whole-page) 'whole-page) + +;;@menu +;;* Column Ranges:: +;;* Drawing the Graph:: +;;* Graphics Context:: +;;* Rectangles:: +;;* Legending:: +;;* Legacy Plotting:: +;;* Example Graph:: +;;@end menu +;; +;;@node Column Ranges, Drawing the Graph, PostScript Graphing, PostScript Graphing +;;@subsubsection Column Ranges + +;;@noindent +;;A @dfn{range} is a list of two numbers, the minimum and the maximum. +;;@cindex range +;;Ranges can be given explicity or computed in PostScript by +;;@code{column-range}. + +;;@body +;;Returns the range of values in 2-dimensional @1 column @2. +(define (column-range array k) + (set! array (import-array array)) + (scheme->ps array " " k " column-range")) + +;;@body +;;Expands @1 by @2/100 on each end. +(define (pad-range range p) (scheme->ps range " " p " pad-range")) + +;;@body +;;Expands @1 to round number of ticks. +(define (snap-range range) (scheme->ps range " snap-range")) + +;;@args range1 range2 ... +;;Returns the minimal range covering all @1, @2, ... +(define (combine-ranges rng1 . rngs) + (define (loop rngs) + (cond ((null? rngs) "") + (else (scheme->ps " " (car rngs) (loop (cdr rngs)) + " combine-ranges")))) + (scheme->ps rng1 (loop rngs))) + +;;@args x-range y-range pagerect +;;@args x-range y-range +;;@1 and @2 should each be a list of two numbers or the value returned +;;by @code{pad-range}, @code{snap-range}, or @code{combine-range}. +;;@3 is the rectangle bounding the graph to be drawn; if missing, the +;;rectangle from the top of the PostScript stack is popped and used. +;; +;;Based on the given ranges, @0 sets up scaling and margins for making +;;a graph. The margins are sized proportional to the @var{fontheight} +;;value at the time of the call to setup-plot. @0 sets two variables: +;; +;;@table @var +;;@item plotrect +;;The region where data points will be plotted. +;;@item graphrect +;;The @3 argument to @0. Includes plotrect, legends, etc. +;;@end table +(define (setup-plot xrange yrange . pagerect) + (if (null? pagerect) + (scheme->ps xrange " " yrange " setup-plot") + (scheme->ps (car pagerect) " " xrange " " yrange " setup-plot"))) + +;;@node Drawing the Graph, Graphics Context, Column Ranges, PostScript Graphing +;;@subsubsection Drawing the Graph + +;;@body +;;Plots points with x coordinate in @2 of @1 and y coordinate @3 of +;;@1. The symbol @4 specifies the type of glyph or drawing style for +;;presenting these coordinates. +(define (plot-column array x-column y-column proc3s) + (set! array (import-array array)) + (scheme->ps "[ " array " " x-column " " y-column " ] " proc3s + " plot-column")) + +;;@noindent +;;The glyphs and drawing styles available are: +;; +;;@table @code +;;@item line +;;Draws line connecting points in order. +;;@item mountain +;;Fill area below line connecting points. +;;@item cloud +;;Fill area above line connecting points. +;;@item impulse +;;Draw line from x-axis to each point. +;;@item bargraph +;;Draw rectangle from x-axis to each point. +;;@item disc +;;Solid round dot. +;;@item point +;;Minimal point -- invisible if linewidth is 0. +;;@item square +;;Square box. +;;@item diamond +;;Square box at 45.o +;;@item plus +;;Plus sign. +;;@item cross +;;X sign. +;;@item triup +;;Triangle pointing upward +;;@item tridown +;;Triangle pointing downward +;;@item pentagon +;;Five sided polygon +;;@item circle +;;Hollow circle +;;@end table + + +;;@node Graphics Context, Rectangles, Drawing the Graph, PostScript Graphing +;;@subsubsection Graphics Context + +;;@body +;;Saves the current graphics state, executes @1, then restores +;;to saved graphics state. +(define (in-graphic-context . args) + (append '("gsave pointsize glyphsize") + args + '("/glyphsize exch def /pointsize exch def grestore"))) + +;;@args color +;;@1 should be a string naming a Resene color, a saturate color, or a +;;number between 0 and 100. +;; +;;@0 sets the PostScript color to the color of the given string, or a +;;grey value between black (0) and white (100). +(define (set-color clrn) + (define clr + (cond ((color? clrn) clrn) + ((number? clrn) (* 255/100 clrn)) + ((or (eq? 'black clrn) + (and (string? clrn) (string-ci=? "black" clrn))) 0) + ((or (eq? 'white clrn) + (and (string? clrn) (string-ci=? "white" clrn))) 255) + (else (or (saturate clrn) (resene clrn) + (string->color (if (symbol? clrn) + (symbol->string clrn) + clrn)))))) + (define (num->str x) + (define num (inexact->exact (round (+ 1000 (* x 999/255))))) + (scheme->ps "." (substring (number->string num) 1 4) " ")) + (cond ((number? clr) (string-append (num->str clr) " setgray")) + (clr (apply scheme->ps + (append (map num->str (color->sRGB clr)) '(setrgbcolor)))) + (else ""))) + +;;@body +;;@1 should be a (case-sensitive) string naming a PostScript font. +;;@2 should be a positive real number. +;; +;;@0 Changes the current PostScript font to @1 with height equal to +;;@2. The default font is Helvetica (12pt). +(define (set-font name fontheight) + (scheme->ps "/pointsize " fontheight " def /" name " pointsize selectfont")) + +;;@noindent +;;The base set of PostScript fonts is: +;; +;;@multitable @columnfractions .20 .25 .25 .30 +;;@item Times @tab Times-Italic @tab Times-Bold @tab Times-BoldItalic +;;@item Helvetica @tab Helvetica-Oblique @tab Helvetica-Bold @tab Helvetica-BoldOblique +;;@item Courier @tab Courier-Oblique @tab Courier-Bold @tab Courier-BoldOblique +;;@item Symbol +;;@end multitable + +;;@noindent +;;Line parameters do no affect fonts; they do effect glyphs. + +;;@body +;;The default linewidth is 1. Setting it to 0 makes the lines drawn +;;as skinny as possible. Linewidth must be much smaller than +;;glyphsize for readable glyphs. +(define (set-linewidth w) (scheme->ps w " setlinewidth")) + +;;@args j k +;;Lines are drawn @1-on @2-off. +;;@args j +;;Lines are drawn @1-on @1-off. +;;@args +;;Turns off dashing. +(define (set-linedash . args) (scheme->ps args " 0 setdash")) + +;;@body +;;Sets the (PostScript) variable glyphsize to @1. The default +;;glyphsize is 6. +(define (set-glyphsize w) (scheme->ps "/glyphsize " w " def")) + +;;@noindent +;;The effects of @code{clip-to-rect} are also part of the graphic +;;context. + + +;;@node Rectangles, Legending, Graphics Context, PostScript Graphing +;;@subsubsection Rectangles + +;;@noindent +;;A @dfn{rectangle} is a list of 4 numbers; the first two elements are +;;the x and y coordinates of lower left corner of the rectangle. The +;;other two elements are the width and height of the rectangle. + +;;@body +;;Pushes a rectangle for the whole encapsulated page onto the +;;PostScript stack. This pushed rectangle is an implicit argument to +;;@code{partition-page} or @code{setup-plot}. +(define (whole-page) 'whole-page) + +;;@body +;;Pops the rectangle currently on top of the stack and pushes @1 * @2 +;;sub-rectangles onto the stack in decreasing y and increasing x order. +;;If you are drawing just one graph, then you don't need @0. +(define (partition-page xparts yparts) + (scheme->ps xparts " " yparts " partition-page")) + +;;@body +;;The rectangle where data points should be plotted. @0 is set by +;;@code{setup-plot}. +(define plotrect 'plotrect) + +;;@body +;;The @var{pagerect} argument of the most recent call to +;;@code{setup-plot}. Includes plotrect, legends, etc. +(define graphrect 'graphrect) + +;;@body +;;fills @1 with the current color. +(define (fill-rect rect) (scheme->ps rect " fill-rect")) + +;;@body +;;Draws the perimiter of @1 in the current color. +(define (outline-rect rect) (scheme->ps rect " outline-rect")) + +;;@body +;;Modifies the current graphics-state so that nothing will be drawn +;;outside of the rectangle @1. Use @code{in-graphic-context} to limit +;;the extent of @0. +(define (clip-to-rect rect) (scheme->ps rect " clip-to-rect")) + + +;;@node Legending, Legacy Plotting, Rectangles, PostScript Graphing +;;@subsubsection Legending + +;;@args title subtitle +;;@args title +;;Puts a @1 line and an optional @2 line above the @code{graphrect}. +(define (title-top title . subtitle) + (set! *plot-title* title) + (scheme->ps "(" title ") (" + (if (null? subtitle) "" (car subtitle)) + ") title-top")) + +;;@args title subtitle +;;@args title +;;Puts a @1 line and an optional @2 line below the @code{graphrect}. +(define (title-bottom title . subtitle) + (set! *plot-title* title) + (scheme->ps "(" title ") (" + (if (null? subtitle) "" (car subtitle)) + ") title-bottom")) + +;;@body +;;These edge coordinates of @code{graphrect} are suitable for passing +;;as the first argument to @code{rule-horizontal}. +(define topedge 'topedge) +(define bottomedge 'bottomedge) + +;;@body +;;These edge coordinates of @code{graphrect} are suitable for passing +;;as the first argument to @code{rule-vertical}. +(define leftedge 'leftedge) +(define rightedge 'rightedge) + +;;@body +;;Draws a vertical ruler with X coordinate @1 and labeled with string +;;@2. If @3 is positive, then the ticks are @3 long on the right side +;;of @1; and @2 and numeric legends are on the left. If @3 is +;;negative, then the ticks are -@3 long on the left side of @1; and @2 +;;and numeric legends are on the right. +(define (rule-vertical x-coord text tick-width) + (scheme->ps x-coord " (" text ") " tick-width " rule-vertical")) + +;;@body +;;Draws a horizontal ruler with X coordinate @1 and labeled with +;;string @2. If @3 is positive, then the ticks are @3 long on the +;;right side of @1; and @2 and numeric legends are on the left. If @3 +;;is negative, then the ticks are -@3 long on the left side of @1; and +;;@2 and numeric legends are on the right. +(define (rule-horizontal x-coord text tick-height) + (scheme->ps x-coord " (" text ") " tick-height " rule-horizontal")) + +;;@body +;;Draws the y-axis. +(define (y-axis) 'y-axis) +;;@body +;;Draws the x-axis. +(define (x-axis) 'x-axis) +;;@body +;;Draws vertical lines through @code{graphrect} at each tick on the +;;vertical ruler. +(define (grid-verticals) 'grid-verticals) +;;@body +;;Draws horizontal lines through @code{graphrect} at each tick on the +;;horizontal ruler. +(define (grid-horizontals) 'grid-horizontals) + +;;@node Legacy Plotting, Example Graph, Legending, PostScript Graphing +;;@subsubsection Legacy Plotting + +(define (graph:plot tmp data xlabel ylabel . histogram?) + (set! histogram? (if (null? histogram?) #f (car histogram?))) + (if (list? data) + (let ((len (length data)) + (nra (create-array (Ar64) (length data) 2))) + (do ((idx 0 (+ 1 idx)) + (lst data (cdr lst))) + ((>= idx len) + (set! data nra)) + (array-set! nra (caar lst) idx 0) + (array-set! nra (if (list? (cdar lst)) (cadar lst) (cdar lst)) + idx 1)))) + (create-postscript-graph + tmp (or graph:dimensions '(600 300)) + (whole-page) (setup-plot (column-range data 0) (column-range data 1)) + (outline-rect plotrect) + (x-axis) (y-axis) + (plot-column data 0 1 (if histogram? 'bargraph 'line)) + (rule-vertical leftedge ylabel 10) + (rule-horizontal bottomedge xlabel 10))) + +(define (graph:plot-function tmp func vlo vhi . npts) + (set! npts (if (null? npts) 200 (car npts))) + (let ((dats (create-array (Ar64) npts 2))) + (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) + (lambda (idx) + (+ vlo (* (- vhi vlo) (/ idx (+ -1 npts)))))) + (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts) + func + (make-shared-array dats (lambda (idx) (list idx 0)) npts)) + (graph:plot tmp dats "" ""))) + +;;@body +;;A list of the width and height of the graph to be plotted using +;;@code{plot}. +(define graph:dimensions #f) + +;;@args func x1 x2 npts +;;@args func x1 x2 +;;Creates and displays using @code{(system "gv tmp.eps")} an +;;encapsulated PostScript graph of the function of one argument @1 +;;over the range @2 to @3. If the optional integer argument @4 is +;;supplied, it specifies the number of points to evaluate @1 at. +;; +;;@defunx plot coords x-label y-label +;;@var{coords} is a list or vector of coordinates, lists of x and y +;;coordinates. @var{x-label} and @var{y-label} are strings with which +;;to label the x and y axes. +(define (plot . args) + (call-with-tmpnam + (lambda (tmp) + (if (procedure? (car args)) + (apply graph:plot-function tmp args) + (apply graph:plot tmp args)) + (system (string-append "gv '" tmp "'"))) + ".eps")) + + +;;@node Example Graph, , Legacy Plotting, PostScript Graphing +;;@subsubsection Example Graph + +;;@noindent +;;The file @file{am1.5.html}, a table of solar irradiance, is fetched +;;with @samp{wget} if it isn't already in the working directory. The +;;file is read and stored into an array, @var{irradiance}. +;; +;;@code{create-postscript-graph} is then called to create an +;;encapsulated-PostScript file, @file{solarad.eps}. The size of the +;;page is set to 600 by 300. @code{whole-page} is called and leaves +;;the rectangle on the PostScript stack. @code{setup-plot} is called +;;with a literal range for x and computes the range for column 1. +;; +;;Two calls to @code{top-title} are made so a different font can be +;;used for the lower half. @code{in-graphic-context} is used to limit +;;the scope of the font change. The graphing area is outlined and a +;;rule drawn on the left side. +;; +;;Because the X range was intentionally reduced, +;;@code{in-graphic-context} is called and @code{clip-to-rect} limits +;;drawing to the plotting area. A black line is drawn from data +;;column 1. That line is then overlayed with a mountain plot of the +;;same column colored "Bright Sun". +;; +;;After returning from the @code{in-graphic-context}, the bottom ruler +;;is drawn. Had it been drawn earlier, all its ticks would have been +;;painted over by the mountain plot. +;; +;;The color is then changed to @samp{seagreen} and the same graphrect +;;is setup again, this time with a different Y scale, 0 to 1000. The +;;graphic context is again clipped to @var{plotrect}, linedash is set, +;;and column 2 is plotted as a dashed line. Finally the rightedge is +;;ruled. Having the line and its scale both in green helps +;;disambiguate the scales. + +;;@example +;;(require 'eps-graph) +;;(require 'line-i/o) +;;(require 'string-port) +;; +;;(define irradiance +;; (let ((url "http://www.pv.unsw.edu.au/am1.5.html") +;; (file "am1.5.html")) +;; (define (read->list line) +;; (define elts '()) +;; (call-with-input-string line +;; (lambda (iprt) (do ((elt (read iprt) (read iprt))) +;; ((eof-object? elt) elts) +;; (set! elts (cons elt elts)))))) +;; (if (not (file-exists? file)) +;; (system (string-append "wget -c -O" file " " url))) +;; (call-with-input-file file +;; (lambda (iprt) +;; (define lines '()) +;; (do ((line (read-line iprt) (read-line iprt))) +;; ((eof-object? line) +;; (let ((nra (create-array (Ar64) +;; (length lines) +;; (length (car lines))))) +;; (do ((lns lines (cdr lns)) +;; (idx (+ -1 (length lines)) (+ -1 idx))) +;; ((null? lns) nra) +;; (do ((kdx (+ -1 (length (car lines))) (+ -1 kdx)) +;; (lst (car lns) (cdr lst))) +;; ((null? lst)) +;; (array-set! nra (car lst) idx kdx))))) +;; (if (and (positive? (string-length line)) +;; (char-numeric? (string-ref line 0))) +;; (set! lines (cons (read->list line) lines)))))))) +;; +;;(let ((xrange '(.25 2.5))) +;; (create-postscript-graph +;; "solarad.eps" '(600 300) +;; (whole-page) +;; (setup-plot xrange (column-range irradiance 1)) +;; (title-top +;; "Solar Irradiance http://www.pv.unsw.edu.au/am1.5.html") +;; (in-graphic-context +;; (set-font "Helvetica-Oblique" 12) +;; (title-top +;; "" +;; "Key Centre for Photovoltaic Engineering UNSW - Air Mass 1.5 Global Spectrum")) +;; (outline-rect plotrect) +;; (rule-vertical leftedge "W/(m^2.um)" 10) +;; (in-graphic-context (clip-to-rect plotrect) +;; (plot-column irradiance 0 1 'line) +;; (set-color "Bright Sun") +;; (plot-column irradiance 0 1 'mountain) +;; ) +;; (rule-horizontal bottomedge "Wavelength in .um" 5) +;; (set-color 'seagreen) +;; +;; (setup-plot xrange '(0 1000) graphrect) +;; (in-graphic-context (clip-to-rect plotrect) +;; (set-linedash 5 2) +;; (plot-column irradiance 0 2 'line)) +;; (rule-vertical rightedge "Integrated .W/(m^2)" -10) +;; )) +;; +;;(system "gv solarad.eps") +;;@end example |