codepad

Language:

; plotter - plot graph based on input parameters

(define (make-matrix rows columns . value)
  (do ((m (make-vector rows)) (i 0 (+ i 1)))
      ((= i rows) m)
    (if (null? value)
        (vector-set! m i (make-vector columns))
        (vector-set! m i (make-vector columns (car value))))))
(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
(define-syntax for
  (syntax-rules ()
    ((for (var first past step) body ...)
      (let ((ge? (if (< first past) >= <=)))
        (do ((var first (+ var step)))
            ((ge? var past))
          body ...)))
    ((for (var first past) body ...)
      (let* ((f first) (p past) (s (if (< first past) 1 -1)))
        (for (var f p s) body ...)))
    ((for (var past) body ...)
      (let* ((p past)) (for (var 0 p) body ...)))))

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define height 24) ; number of printable rows
(define width 80) ; number of printable columns
(define ox 10) ; x-origin, leave room for y-ticks
(define oy 1) ; y-origin, leave room for x-ticks

(define label #f) ; graph label on top row
(define y-lo #f) ; lo end of y-axis
(define y-hi #f) ; hi end of y-axis
(define x-lo #f) ; lo end of x-axis
(define x-hi #f) ; hi end of x-axis
(define y-ticks (list)) ; list of y-axis tick marks
(define x-ticks (list)) ; list of x-axis tick marks
(define data (list)) ; list of x/y points to plot
(define grid (make-matrix width height #\space))

(define (graph file-name)
  (set! label #f) (set! y-lo #f) (set! y-hi #f) (set! x-lo #f) (set! x-hi #f)
  (set! y-ticks (list)) (set! x-ticks (list)) (set! data (list))
  (set! grid (make-matrix width height #\space)) 
  (with-input-from-file file-name (lambda ()
    (let loop ((line (read-line)))
      (if (eof-object? line) (plot)
        (let ((fields (string-split #\space line)))
          (cond ((null? fields) (verify-parameters))
                ((null? (cddr fields))
                  (set! data (cons (cons (string->number (car fields))
                                         (string->number (cadr fields))) data)))
                ((string=? (car fields) "label")
                  (set! label (substring line
                    (+ (string-length "label") 1)
                    (string-length line))))
                ((and (string=? (car fields) "left")
                      (string=? (cadr fields) "range"))
                  (set! y-lo (string->number (caddr fields)))
                  (set! y-hi (string->number (cadddr fields))))
                ((and (string=? (car fields) "bottom")
                      (string=? (cadr fields) "range"))
                  (set! x-lo (string->number (caddr fields)))
                  (set! x-hi (string->number (cadddr fields))))
                ((and (string=? (car fields) "left")
                      (string=? (cadr fields) "ticks"))
                  (set! y-ticks (map string->number (cddr fields))))
                ((and (string=? (car fields) "bottom")
                      (string=? (cadr fields) "ticks"))
                  (set! x-ticks (map string->number (cddr fields))))
                (else (error 'graph "unrecognized input")))
        (loop (read-line))))))))

(define (verify-parameters)
  (when (not (and label y-lo y-hi x-lo x-hi y-ticks x-ticks))
    (error 'verify-parameters "missing parameters"))
  (when (not (< y-lo y-hi))
    (error 'verify-parameters "invalid left range"))
  (when (not (< x-lo x-hi))
    (error 'verify-parameters "invalid bottom range"))
  (when (not (apply < y-ticks))
    (error 'verify-parameters "invalid left ticks"))
  (when (not (apply < x-ticks))
    (error 'verify-parameters "invalid bottom ticks")

(define (plot)
  (frame) (ticks) (labels) (points) (draw))

(define (frame)
  (for (i ox width)
    (matrix-set! grid i oy #\-)
    (matrix-set! grid i (- height 2) #\-))
  (for (i oy (- height 1))
    (matrix-set! grid ox i #\|)
    (matrix-set! grid (- width 1) i #\|)))

(define (ticks)
  (do ((ts y-ticks (cdr ts))) ((null? ts))
    (matrix-set! grid ox (y-scale (car ts)) #\-)
    (display-at (y-scale (car ts)) (- ox 1 (string-length (number->string (car ts))))
      (number->string (car ts))))
  (do ((ts x-ticks (cdr ts))) ((null? ts))
    (matrix-set! grid (x-scale (car ts)) oy #\|)
    (display-at (- oy 1) (- (x-scale (car ts))
      (quotient (string-length (number->string (car ts))) 2))
      (number->string (car ts)))))

(define (labels)
  (display-at (- height oy) (quotient (- width (string-length label)) 2) label))

(define (points)
  (do ((ds data (cdr ds))) ((null? ds))
    (matrix-set! grid (x-scale (caar ds)) (y-scale (cdar ds)) #\*)))

(define (x-scale x)
  (round (+ (* (/ (- x x-lo) (- x-hi x-lo)) (- width 1 ox)) ox)))

(define (y-scale y)
  (round (+ (* (/ (- y y-lo) (- y-hi y-lo)) (- height 3 oy)) oy)))

(define (display-at r c str)
  (for (i 0 (string-length str))
    (matrix-set! grid (+ i c) r (string-ref str i))))

(define (draw)
  (for (r (- height 1) -1 -1)
    (for (c 0 width)
      (display (matrix-ref grid c r)))
    (newline)))

Private [?]

Run code