Import Upstream version 3a1upstream/3a1

1 files changed, 254 insertions, 126 deletions

diff --git a/charplot.scm b/charplot.scm
index 3e0e019..890fca0 100644
--- a/charplot.scm
+++ b/charplot.scm
@@ -1,5 +1,5 @@
 ;;;; "charplot.scm", plotting on character devices for Scheme
-;;; Copyright (C) 1992, 1993 Aubrey Jaffer
+;;; Copyright (C) 1992, 1993, 2001, 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
@@ -8,7 +8,7 @@
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
 ;
-;2.  I have made no warrantee or representation that the operation of
+;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.
 ;
@@ -17,155 +17,283 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-(require 'sort)
 (require 'printf)
 (require 'array)
 (require 'array-for-each)
+(require 'multiarg/and-)
 
-(define charplot:rows 24)
-(define charplot:columns (output-port-width (current-output-port)))
+;;;@ These determine final graph size.
+(define charplot:dimensions #f)
 
-(define charplot:xborder #\_)
-(define charplot:yborder #\|)
-(define charplot:xaxchar #\-)
-(define charplot:yaxchar #\:)
-(define charplot:curve1 #\*)
-(define charplot:xtick #\.)
+;;; The left margin and legends
+(define charplot:left-margin 12)
 
-(define charplot:height (- charplot:rows 5))
-(define charplot:width (- charplot:columns 15))
+(define char:xborder #\_)
+(define char:yborder #\|)
+(define char:xaxis   #\-)
+(define char:yaxis   #\:)
+(define char:xtick   #\.)
+(define char:bar     #\I)
+(define char:curves  "*+x@#$%&='")
 
-(define (charplot:printn! n char)
-  (cond ((positive? n)
-	 (write-char char)
-	 (charplot:printn! (+ n -1) char))))
+;;;Converts X to a string whose length is at most MWID.
+(define (charplot:number->string x mwid)
+  (define str (sprintf #f "%g" x))
+  (if (> (string-length str) mwid)
+      (substring str 0 mwid)
+      str))
 
-(define (charplot:center-print! str width)
-  (let ((lpad (quotient (- width (string-length str)) 2)))
-    (charplot:printn! lpad #\ )
-    (display str)
-    (charplot:printn! (- width (+ (string-length  str) lpad)) #\ )))
-
-(define (charplot:number->string x)
-  (sprintf #f "%g" x))
-
-(define (charplot:scale-it z scale)
-  (if (and (exact? z) (integer? z))
-      (quotient (* z (car scale)) (cadr scale))
-      (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
+;;;SCALE is a list of numerator and denominator.
+(define charplot:scale-it
+  (if (provided? 'inexact)
+      (lambda (z scale)
+	(inexact->exact (round (/ (* z (car scale)) (cadr scale)))))
+      (lambda (z scale)
+	(quotient (+ (* z (car scale)) (quotient (cadr scale) 2))
+		  (cadr scale)))))
 
+;;; Given the width or height (in characters) and the data-span,
+;;; returns a list of numerator and denominator (NUM DEN) suitable for
+;;; passing as a second argument to CHARPLOT:SCALE-IT.
+;;;
+;;; NUM will be 1, 2, 3, 4, 5, 6, or 8 times a power of ten.
+;;; DEN will be a power of ten.
+;;;
+;;; num   isize
+;;; === < =====
+;;; den   delta
 (define (charplot:find-scale isize delta)
-  (define (fs2)
-    (cond ((< (* delta 8) isize) 8)
-	  ((< (* delta 6) isize) 6)
-	  ((< (* delta 5) isize) 5)
-	  ((< (* delta 4) isize) 4)
-	  ((< (* delta 3) isize) 3)
-	  ((< (* delta 2) isize) 2)
-	  (else 1)))
   (cond ((zero? delta) (set! delta 1))
 	((inexact? delta) (set! isize (exact->inexact isize))))
-  (do ((d 1 (* d 10)))
+  (do ((d 1 (* d 10))
+       (isize isize (* isize 10)))
       ((<= delta isize)
-       (do ((n 1 (* n 10)))
+       (do ((n 1 (* n 10))
+	    (delta delta (* delta 10)))
 	   ((>= (* delta 10) isize)
-	    (list (* n (fs2)) d))
-	 (set! delta (* delta 10))))
-    (set! isize (* isize 10))))
+	    (list (* n (cond ((<= (* delta 8) isize) 8)
+			     ((<= (* delta 6) isize) 6)
+			     ((<= (* delta 5) isize) 5)
+			     ((<= (* delta 4) isize) 4)
+			     ((<= (* delta 3) isize) 3)
+			     ((<= (* delta 2) isize) 2)
+			     (else 1)))
+		  d))))))
+
+(define (charplot:make-array)
+  (let ((height (or (and charplot:dimensions (car charplot:dimensions))
+		    (output-port-height (current-output-port))))
+	(width (or  (and charplot:dimensions (cadr charplot:dimensions))
+		    (output-port-width (current-output-port)))))
+    (define pra (create-array " "  height width))
+    ;;Put newlines on right edge
+    (do ((idx (+ -1 height) (+ -1 idx)))
+	((negative? idx))
+      (array-set! pra #\newline idx (+ -1 width)))
+    pra))
 
-(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
+;;;Creates and initializes character array with axes, scales, and
+;;;labels.
+(define (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale)
+  (define plot-height (- (car (array-dimensions pra)) 3))
+  (define plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4))
   (define xaxis (- (charplot:scale-it ymin yscale)))
   (define yaxis (- (charplot:scale-it xmin xscale)))
-  (charplot:center-print! ylabel 11)
-  (charplot:printn! (+ charplot:width 1) charplot:xborder)
-  (newline)
-  (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y))
-					   (< (car x) (car y))
-					   (> (cdr x) (cdr y))))))
-  (do ((ht (- charplot:height 1) (- ht 1)))
+  (define xstep (if (zero? (modulo (car xscale) 3)) 12 10))
+  ;;CL is the left edge of WIDTH field
+  (define (center-field str width ln cl)
+    (define len (string-length str))
+    (if (< width len)
+	(center-field (substring str 0 width) width ln cl)
+	(do ((cnt (+ -1 len) (+ -1 cnt))
+	     (adx (+ (quotient (- width len) 2) cl) (+ 1 adx))
+	     (idx 0 (+ 1 idx)))
+	    ((negative? cnt))
+	  (array-set! pra (string-ref str idx) ln adx))))
+
+  ;;x and y labels
+  (center-field ylabel (+ charplot:left-margin -1) 0 0)
+  (center-field xlabel (+ -1 charplot:left-margin) (+ 2 plot-height) 0)
+
+  ;;horizontal borders, x-axis, and ticking
+  (let ((xstep/2 (quotient (- xstep 2) 2)))
+    (define faxis (modulo (+ charplot:left-margin yaxis) xstep))
+    (define faxis/2 (modulo (+ charplot:left-margin yaxis xstep/2 1) xstep))
+    (define xfudge (modulo yaxis xstep))
+    (do ((cl (+ charplot:left-margin -1) (+ 1 cl)))
+	((>= cl (+ plot-width charplot:left-margin)))
+      (array-set! pra char:xborder 0 cl)
+      (array-set! pra
+		  (cond ((eqv? faxis (modulo cl xstep)) char:yaxis)
+			((eqv? faxis/2 (modulo cl xstep)) char:xtick)
+			(else char:xborder))
+		  (+ 1 plot-height) cl)
+      (if (<= 0 xaxis plot-height)
+	  (array-set! pra char:xaxis (- plot-height xaxis) cl)))
+
+    ;;horizontal coordinates
+    (do ((i xfudge (+ i xstep))
+	 (cl (+ charplot:left-margin xfudge (- xstep/2)) (+ xstep cl)))
+	((> i plot-width))
+      (center-field (charplot:number->string
+		     (/ (* (- i yaxis) (cadr xscale))
+			(car xscale))
+		     xstep)
+		    xstep (+ 2 plot-height) cl)))
+
+  ;;vertical borders and y-axis
+  (do ((ht plot-height (- ht 1)))
+      ((negative? ht))
+    (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin -2))
+    (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin plot-width))
+    (if (< -1 yaxis plot-width)
+	(array-set! pra char:yaxis (+ 1 ht) (+ charplot:left-margin yaxis))))
+
+  ;;vertical ticking and coordinates
+  (do ((ht (- plot-height 1) (- ht 1))
+       (ln 1 (+ 1 ln)))
       ((negative? ht))
-    (let ((a (make-string (+ charplot:width 1)
-			  (if (= ht xaxis) charplot:xaxchar #\ )))
-	  (ystep (if (= 1 (gcd (car yscale) 3)) 2 3)))
-      (string-set! a charplot:width charplot:yborder)
-      (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar))
-      (do ()
-	  ((or (null? data) (not (>= (cdar data) ht))))
-	(string-set! a (caar data) charplot:curve1)
-	(set! data (cdr data)))
+    (let ((ystep (if (zero? (modulo (car yscale) 3)) 3 2)))
       (if (zero? (modulo (- ht xaxis) ystep))
 	  (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale))
-						(car yscale))))
-		 (l (string-length v)))
-	    (if (> l 10)
-		(display (substring v 0 10))
-		(begin
-		  (charplot:printn! (- 10 l) #\ )
-		  (display v)))
-	    (display charplot:yborder)
-	    (display charplot:xaxchar))
-	  (begin
-	    (charplot:printn! 10 #\ )
-	    (display charplot:yborder)
-	    (display #\ )))
-      (display a) (newline)))
-  (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12))
-	 (xstep/2 (quotient (- xstep 2) 2))
-	 (fudge (modulo yaxis xstep)))
-    (charplot:printn! 10 #\ ) (display charplot:yborder)
-    (charplot:printn! (+ 1 fudge) charplot:xborder)
-    (display charplot:yaxchar)
-    (do ((i fudge (+ i xstep)))
-	((> (+ i xstep) charplot:width)
-	 (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep)
-			   charplot:xborder))
-      (charplot:printn! xstep/2 charplot:xborder)
-      (display charplot:xtick)
-      (charplot:printn! xstep/2 charplot:xborder)
-      (display charplot:yaxchar))
-    (display charplot:yborder) (newline)
-    (charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
-    (do ((i fudge (+ i xstep)))
-	((>= i charplot:width))
-      (charplot:center-print! (charplot:number->string
-			       (/ (* (- i yaxis) (cadr xscale))
-				  (car xscale)))
-			      xstep))
-    (newline)))
-
-(define (charplot:plot! data xlabel ylabel)
+						(car yscale))
+					     (+ charplot:left-margin -2)))
+		 (len (string-length v)))
+	    (center-field v len ln (- charplot:left-margin 2 len)) ;Actually flush right
+	    (array-set! pra char:xaxis ln (+ charplot:left-margin -1))))))
+  ;;return initialized array
+  pra)
+
+(define (charplot:array->list ra)
+  (define dims (array-dimensions ra))
+  (do ((idx (+ -1 (car dims)) (+ -1 idx))
+       (cols '() (cons (do ((jdx (+ -1 (cadr dims)) (+ -1 jdx))
+			    (row '() (cons (array-ref ra idx jdx) row)))
+			   ((negative? jdx) row))
+		       cols)))
+      ((negative? idx) cols)))
+
+;;;Converts data to list of coordinates (list).
+(define (charplot:data->lists data)
   (cond ((array? data)
 	 (case (array-rank data)
-	   ((1) (set! data (map cons
-				(let ((ra (apply make-array #f
+	   ((1) (set! data (map list
+				(let ((ra (apply create-array '#()
 						 (array-shape data))))
 				  (array-index-map! ra identity)
-				  (array->list ra))
-				(array->list data))))
-	   ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst)))
-				(array->list data)))))))
-  (let* ((xmax (apply max (map car data)))
-	 (xmin (apply min (map car data)))
-	 (xscale (charplot:find-scale charplot:width (- xmax xmin)))
-	 (ymax (apply max (map cdr data)))
-	 (ymin (apply min (map cdr data)))
-	 (yscale (charplot:find-scale charplot:height (- ymax ymin)))
-	 (ixmin (charplot:scale-it xmin xscale))
-	 (iymin (charplot:scale-it ymin yscale)))
-    (charplot:iplot! (map (lambda (p)
-			    (cons (- (charplot:scale-it (car p) xscale) ixmin)
-				  (- (charplot:scale-it (cdr p) yscale) iymin)))
-			  data)
-		     xlabel ylabel xmin xscale ymin yscale)))
-
-(define (plot-function! func vlo vhi . npts)
-  (set! npts (if (null? npts) 100 (car npts)))
-  (let ((dats (make-array 0.0 npts 2)))
+				  (charplot:array->list ra))
+				(charplot:array->list data))))
+	   ((2) (set! data (charplot:array->list data)))))
+	((and (pair? (car data)) (not (list? (car data))))
+	 (set! data (map (lambda (lst) (list (car lst) (cdr lst))) data))))
+  (cond ((list? (cadar data))
+	 (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) data))))
+  data)
+
+;;;An extremum is a list of the maximum and minimum values.
+;;;COORDINATE-EXTREMA returns a rank-length list of these.
+(define (coordinate-extrema data)
+  (define extrema (map (lambda (x) (list x x)) (car data)))
+  (for-each (lambda (lst)
+	      (set! extrema (map (lambda (x max-min)
+				   (list (max x (car max-min))
+					 (min x (cadr max-min))))
+				 lst extrema)))
+	    data)
+  extrema)
+
+;;;Count occurrences of numbers within evenly spaced ranges; and return
+;;;lists of coordinates for graph.
+(define (histobins data plot-width)
+  (define datcnt (length data))
+  (define xmax (apply max data))
+  (define xmin (apply min data))
+  (if (null? data)
+      '()
+      (let* ((xscale (charplot:find-scale plot-width (- xmax xmin)))
+	     (actual-width (- (charplot:scale-it xmax xscale)
+			      (charplot:scale-it xmin xscale)
+			      -1)))
+	(define ix-min (charplot:scale-it xmin xscale))
+	(define xinc (/ (- xmax xmin) actual-width))
+	(define bins (make-vector actual-width 0))
+	(for-each (lambda (x)
+		    (define idx (- (charplot:scale-it x xscale) ix-min))
+		    (if (< -1 idx actual-width)
+			(vector-set! bins idx (+ 1 (vector-ref bins idx)))
+			(slib:error x (/ (* x (car xscale)) (cadr xscale))
+				    (+ ix-min idx))))
+		  data)
+	(map list
+	     (do ((idx (+ -1 (vector-length bins)) (+ -1 idx))
+		  (xvl xmax (- xvl xinc))
+		  (lst '() (cons xvl lst)))
+		 ((negative? idx) lst))
+	     (vector->list bins)))))
+
+;;;@ Plot histogram of DATA.
+(define (histograph data label)
+  (if (vector? data) (set! data (vector->list data)))
+  (charplot:plot (histobins data
+			    (- (or (and charplot:dimensions
+					(cadr charplot:dimensions))
+				   (output-port-width (current-output-port)))
+			       charplot:left-margin 3))
+		 label "" #t))
+
+(define (charplot:plot data xlabel ylabel . histogram?)
+  (define clen (string-length char:curves))
+  (set! histogram? (if (null? histogram?) #f (car histogram?)))
+  (set! data (charplot:data->lists data))
+  (let* ((pra (charplot:make-array))
+	 (plot-height (- (car (array-dimensions pra)) 3))
+	 (plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4))
+	 (extrema (coordinate-extrema data))
+	 (xmax (caar extrema))
+	 (xmin (cadar extrema))
+	 (ymax (apply max (map car (cdr extrema))))
+	 (ymin (apply min (map cadr (cdr extrema))))
+	 (xscale (charplot:find-scale plot-width (- xmax xmin)))
+	 (yscale (charplot:find-scale plot-height (- ymax ymin)))
+	 (ix-min (- (charplot:scale-it xmin xscale) charplot:left-margin))
+	 (ybot (charplot:scale-it ymin yscale))
+	 (iy-min (+ ybot plot-height)))
+    (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale)
+    (for-each (if histogram?
+		  ;;display data bars
+		  (lambda (datum)
+		    (define x (- (charplot:scale-it (car datum) xscale) ix-min))
+		    (do ((y (charplot:scale-it (cadr datum) yscale) (+ -1 y)))
+			((< y ybot))
+		      (array-set! pra char:bar (- iy-min y) x)))
+		  ;;display data points
+		  (lambda (datum)
+		    (define x (- (charplot:scale-it (car datum) xscale) ix-min))
+		    (define cdx 0)
+		    (for-each
+		     (lambda (y)
+		       (array-set! pra (string-ref char:curves cdx)
+				   (- iy-min (charplot:scale-it y yscale)) x)
+		       (set! cdx (modulo (+ 1 cdx) clen)))
+		     (cdr datum))))
+	      data)
+    (array-for-each write-char pra)
+    (if (not (eqv? #\newline (apply array-ref pra
+				    (map cadr (array-shape pra)))))
+	(newline))))
+
+(define (charplot:plot-function func vlo vhi . npts)
+  (set! npts (if (null? npts) 64 (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 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))
-    (charplot:plot! dats "" "")))
-
-(define plot! charplot:plot!)
+    (charplot:plot dats "" "")))
+;@
+(define (plot . args)
+  (if (procedure? (car args))
+      (apply charplot:plot-function args)
+      (apply charplot:plot args)))