module/slib/charplot.scm

   1 ;;;; "charplot.scm", plotting on character devices for Scheme
   2 ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'sort)
  21 (require 'printf)
  22 (require 'array)
  23 (require 'array-for-each)
  24
  25 (define charplot:rows 24)
  26 (define charplot:columns (output-port-width (current-output-port)))
  27
  28 (define charplot:xborder #\_)
  29 (define charplot:yborder #\|)
  30 (define charplot:xaxchar #\-)
  31 (define charplot:yaxchar #\:)
  32 (define charplot:curve1 #\*)
  33 (define charplot:xtick #\.)
  34
  35 (define charplot:height (- charplot:rows 5))
  36 (define charplot:width (- charplot:columns 15))
  37
  38 (define (charplot:printn! n char)
  39   (cond ((positive? n)
  40          (write-char char)
  41          (charplot:printn! (+ n -1) char))))
  42
  43 (define (charplot:center-print! str width)
  44   (let ((lpad (quotient (- width (string-length str)) 2)))
  45     (charplot:printn! lpad #\ )
  46     (display str)
  47     (charplot:printn! (- width (+ (string-length  str) lpad)) #\ )))
  48
  49 (define (charplot:number->string x)
  50   (sprintf #f "%g" x))
  51
  52 (define (charplot:scale-it z scale)
  53   (if (and (exact? z) (integer? z))
  54       (quotient (* z (car scale)) (cadr scale))
  55       (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
  56
  57 (define (charplot:find-scale isize delta)
  58   (define (fs2)
  59     (cond ((< (* delta 8) isize) 8)
  60           ((< (* delta 6) isize) 6)
  61           ((< (* delta 5) isize) 5)
  62           ((< (* delta 4) isize) 4)
  63           ((< (* delta 3) isize) 3)
  64           ((< (* delta 2) isize) 2)
  65           (else 1)))
  66   (cond ((zero? delta) (set! delta 1))
  67         ((inexact? delta) (set! isize (exact->inexact isize))))
  68   (do ((d 1 (* d 10)))
  69       ((<= delta isize)
  70        (do ((n 1 (* n 10)))
  71            ((>= (* delta 10) isize)
  72             (list (* n (fs2)) d))
  73          (set! delta (* delta 10))))
  74     (set! isize (* isize 10))))
  75
  76 (define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
  77   (define xaxis (- (charplot:scale-it ymin yscale)))
  78   (define yaxis (- (charplot:scale-it xmin xscale)))
  79   (charplot:center-print! ylabel 11)
  80   (charplot:printn! (+ charplot:width 1) charplot:xborder)
  81   (newline)
  82   (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y))
  83                                            (< (car x) (car y))
  84                                            (> (cdr x) (cdr y))))))
  85   (do ((ht (- charplot:height 1) (- ht 1)))
  86       ((negative? ht))
  87     (let ((a (make-string (+ charplot:width 1)
  88                           (if (= ht xaxis) charplot:xaxchar #\ )))
  89           (ystep (if (= 1 (gcd (car yscale) 3)) 2 3)))
  90       (string-set! a charplot:width charplot:yborder)
  91       (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar))
  92       (do ()
  93           ((or (null? data) (not (>= (cdar data) ht))))
  94         (string-set! a (caar data) charplot:curve1)
  95         (set! data (cdr data)))
  96       (if (zero? (modulo (- ht xaxis) ystep))
  97           (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale))
  98                                                 (car yscale))))
  99                  (l (string-length v)))
 100             (if (> l 10)
 101                 (display (substring v 0 10))
 102                 (begin
 103                   (charplot:printn! (- 10 l) #\ )
 104                   (display v)))
 105             (display charplot:yborder)
 106             (display charplot:xaxchar))
 107           (begin
 108             (charplot:printn! 10 #\ )
 109             (display charplot:yborder)
 110             (display #\ )))
 111       (display a) (newline)))
 112   (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12))
 113          (xstep/2 (quotient (- xstep 2) 2))
 114          (fudge (modulo yaxis xstep)))
 115     (charplot:printn! 10 #\ ) (display charplot:yborder)
 116     (charplot:printn! (+ 1 fudge) charplot:xborder)
 117     (display charplot:yaxchar)
 118     (do ((i fudge (+ i xstep)))
 119         ((> (+ i xstep) charplot:width)
 120          (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep)
 121                            charplot:xborder))
 122       (charplot:printn! xstep/2 charplot:xborder)
 123       (display charplot:xtick)
 124       (charplot:printn! xstep/2 charplot:xborder)
 125       (display charplot:yaxchar))
 126     (display charplot:yborder) (newline)
 127     (charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
 128     (do ((i fudge (+ i xstep)))
 129         ((>= i charplot:width))
 130       (charplot:center-print! (charplot:number->string
 131                                (/ (* (- i yaxis) (cadr xscale))
 132                                   (car xscale)))
 133                               xstep))
 134     (newline)))
 135
 136 (define (charplot:plot! data xlabel ylabel)
 137   (cond ((array? data)
 138          (case (array-rank data)
 139            ((1) (set! data (map cons
 140                                 (let ((ra (apply make-array #f
 141                                                  (array-shape data))))
 142                                   (array-index-map! ra identity)
 143                                   (array->list ra))
 144                                 (array->list data))))
 145            ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst)))
 146                                 (array->list data)))))))
 147   (let* ((xmax (apply max (map car data)))
 148          (xmin (apply min (map car data)))
 149          (xscale (charplot:find-scale charplot:width (- xmax xmin)))
 150          (ymax (apply max (map cdr data)))
 151          (ymin (apply min (map cdr data)))
 152          (yscale (charplot:find-scale charplot:height (- ymax ymin)))
 153          (ixmin (charplot:scale-it xmin xscale))
 154          (iymin (charplot:scale-it ymin yscale)))
 155     (charplot:iplot! (map (lambda (p)
 156                             (cons (- (charplot:scale-it (car p) xscale) ixmin)
 157                                   (- (charplot:scale-it (cdr p) yscale) iymin)))
 158                           data)
 159                      xlabel ylabel xmin xscale ymin yscale)))
 160
 161 (define (plot-function! func vlo vhi . npts)
 162   (set! npts (if (null? npts) 100 (car npts)))
 163   (let ((dats (make-array 0.0 npts 2)))
 164     (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts)
 165                       (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts)))))
 166     (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts)
 167                 func
 168                 (make-shared-array dats (lambda (idx) (list idx 0)) npts))
 169     (charplot:plot! dats "" "")))
 170
 171 (define plot! charplot:plot!)