Import Upstream version 2a6upstream/2a6

1 files changed, 142 insertions, 0 deletions

diff --git a/charplot.scm b/charplot.scm
new file mode 100644
index 0000000..2a2a49a
--- /dev/null
+++ b/charplot.scm
@@ -0,0 +1,142 @@
+;;;; "charplot.scm", plotting on character devices for Scheme
+;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, 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 warrantee 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 'sort)
+
+(define charplot:rows 24)
+(define charplot:columns (output-port-width (current-output-port)))
+
+(define charplot:xborder #\_)
+(define charplot:yborder #\|)
+(define charplot:xaxchar #\-)
+(define charplot:yaxchar #\:)
+(define charplot:curve1 #\*)
+(define charplot:xtick #\.)
+
+(define charplot:height (- charplot:rows 5))
+(define charplot:width (- charplot:columns 15))
+
+(define (charplot:printn! n char)
+  (cond ((positive? n)
+	 (write-char char)
+	 (charplot:printn! (+ n -1) char))))
+
+(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 (scale-it z scale)
+  (if (and (exact? z) (integer? z))
+      (quotient (* z (car scale)) (cadr scale))
+      (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
+
+(define (find-scale isize delta)
+  (if (inexact? delta) (set! isize (exact->inexact isize)))
+  (do ((d 1 (* d 10)))
+      ((<= delta isize)
+       (do ((n 1 (* n 10)))
+	   ((>= (* delta 10) isize)
+	    (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))
+	 (set! delta (* delta 10))))
+    (set! isize (* isize 10))))
+
+(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
+  (define xaxis (- (scale-it ymin yscale)))
+  (define yaxis (- (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)))
+      ((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)))
+      (if (zero? (modulo (- ht xaxis) ystep))
+	  (let* ((v (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 xstep) charplot:width))
+      (charplot:center-print! (number->string (/ (* (- i yaxis) (cadr xscale))
+						 (car xscale)))
+			      xstep))
+    (newline)))
+
+(define (charplot:plot! data xlabel ylabel)
+  (let* ((xmax (apply max (map car data)))
+	 (xmin (apply min (map car data)))
+	 (xscale (find-scale charplot:width (- xmax xmin)))
+	 (ymax (apply max (map cdr data)))
+	 (ymin (apply min (map cdr data)))
+	 (yscale (find-scale charplot:height (- ymax ymin)))
+	 (ixmin (scale-it xmin xscale))
+	 (iymin (scale-it ymin yscale)))
+    (charplot:iplot! (map (lambda (p)
+			    (cons (- (scale-it (car p) xscale) ixmin)
+				  (- (scale-it (cdr p) yscale) iymin)))
+			  data)
+		     xlabel ylabel xmin xscale ymin yscale)))
+
+(define plot! charplot:plot!)