179 lines
8.5 KiB
Racket
179 lines
8.5 KiB
Racket
(module plot mzscheme
|
|
(require mred
|
|
mzlib/class
|
|
mzlib/contract)
|
|
|
|
|
|
(define-struct data-set (points connected? pen min-x max-x min-y max-y))
|
|
|
|
(define-struct plot-setup (axis-label-font axis-number-font axis-pen grid? grid-pen
|
|
x-axis-marking y-axis-marking x-axis-label y-axis-label))
|
|
|
|
(provide/contract
|
|
(struct data-set ((points (listof (is-a?/c point%)))
|
|
(connected? any/c)
|
|
(pen (is-a?/c pen%))
|
|
(min-x number?)
|
|
(max-x number?)
|
|
(min-y number?)
|
|
(max-y number?)))
|
|
(struct plot-setup ((axis-label-font (is-a?/c font%))
|
|
(axis-number-font (is-a?/c font%))
|
|
(axis-pen (is-a?/c pen%))
|
|
(grid? any/c)
|
|
(grid-pen (is-a?/c pen%))
|
|
(x-axis-marking (listof number?))
|
|
(y-axis-marking (listof number?))
|
|
(x-axis-label string?)
|
|
(y-axis-label string?)))
|
|
(plot ((is-a?/c dc<%>) (listof data-set?) plot-setup? . -> . void?)))
|
|
|
|
(define (draw-text-sideways dc text x y font big-chars? offset)
|
|
(let-values (((width height bot-dist top-dist)
|
|
(send (make-object bitmap-dc% (make-object bitmap% 1 1 #f))
|
|
get-text-extent text font big-chars? offset)))
|
|
(let* ((width (inexact->exact (ceiling width)))
|
|
(height (inexact->exact (ceiling (+ height bot-dist top-dist))))
|
|
(bc (make-object bitmap-dc% (make-object bitmap% width height #f)))
|
|
(new-bc (make-object bitmap-dc% (make-object bitmap% height width #f)))
|
|
(c (make-object color%)))
|
|
(send bc set-font font)
|
|
(send bc clear)
|
|
(send new-bc clear)
|
|
(send bc draw-text text 0 0 big-chars? offset)
|
|
(let loop ((i 0)
|
|
(j 0))
|
|
(cond
|
|
((>= i (+ height top-dist bot-dist))
|
|
(send dc draw-bitmap (send new-bc get-bitmap) x y))
|
|
((>= j width) (loop (add1 i) 0))
|
|
(else
|
|
(send bc get-pixel j i c)
|
|
(send new-bc set-pixel i (- width j) c)
|
|
(loop i (add1 j))))))))
|
|
|
|
|
|
|
|
#cs
|
|
(define (plot dc data-sets ps)
|
|
(let-values (((canvas-width canvas-height) (send dc get-size))
|
|
((_ label-height label-bottom-dist label-top-dist)
|
|
(send dc get-text-extent "" (plot-setup-axis-label-font ps) #f 0))
|
|
((number-width number-height number-bottom-dist number-top-dist)
|
|
(send dc get-text-extent "00.00e-10" (plot-setup-axis-number-font ps) #f 0)))
|
|
(let* ((label-height (+ label-height label-bottom-dist label-top-dist))
|
|
(number-height (+ number-height number-bottom-dist number-top-dist))
|
|
(bottom-space (+ (* 1.5 number-height) label-height))
|
|
(side-space (+ number-width (* .5 number-height) label-height)))
|
|
(cond
|
|
((not (null? data-sets))
|
|
(let* ((mx (apply min (map data-set-min-x data-sets)))
|
|
(my (apply min (map data-set-min-y data-sets)))
|
|
(Mx (apply max (map data-set-max-x data-sets)))
|
|
(My (apply max (map data-set-max-y data-sets)))
|
|
(w-scale (/ (- canvas-width side-space) (- Mx mx)))
|
|
(h-scale (/ (- canvas-height bottom-space) (- my My)))
|
|
(transform-point
|
|
(lambda (p)
|
|
(make-object point%
|
|
(+ side-space (* (- (send p get-x) mx) w-scale))
|
|
(* (- (send p get-y) My) h-scale)))))
|
|
|
|
;; Draw axes
|
|
(send dc set-pen (plot-setup-axis-pen ps))
|
|
(send dc draw-lines
|
|
(map transform-point
|
|
(list (make-object point% mx my)
|
|
(make-object point% Mx my))))
|
|
(send dc draw-lines
|
|
(map transform-point
|
|
(list (make-object point% mx my)
|
|
(make-object point% mx My))))
|
|
|
|
;; draw axis markings
|
|
(send dc set-font (plot-setup-axis-number-font ps))
|
|
(for-each
|
|
(lambda (x)
|
|
(let* ((p (transform-point (make-object point% x my)))
|
|
(draw-x (send p get-x))
|
|
(draw-y-start (+ (send p get-y) (* .5 number-height)))
|
|
(draw-y-stop (- (send p get-y) (* .5 number-height)))
|
|
(str (number->string x)))
|
|
(send dc draw-line draw-x draw-y-start draw-x draw-y-stop)
|
|
(let-values (((number-width x1 x2 x3)
|
|
(send dc get-text-extent
|
|
str (plot-setup-axis-number-font ps) #f 0)))
|
|
(let ((start-x (- draw-x (* .5 number-width))))
|
|
(send dc draw-text str start-x (+ 2 draw-y-start))))))
|
|
(plot-setup-x-axis-marking ps))
|
|
(for-each
|
|
(lambda (y)
|
|
(let* ((p (transform-point (make-object point% mx y)))
|
|
(draw-y (send p get-y))
|
|
(draw-x-start (- (send p get-x) (* .5 number-height)))
|
|
(draw-x-stop (+ (send p get-x) (* .5 number-height)))
|
|
(str (number->string y)))
|
|
(send dc draw-line draw-x-start draw-y draw-x-stop draw-y)
|
|
(let-values (((number-width x1 x2 x3)
|
|
(send dc get-text-extent
|
|
str (plot-setup-axis-number-font ps) #f 0)))
|
|
(let ((start-x (- draw-x-start 2 number-width))
|
|
(start-y (- draw-y (* .5 number-height))))
|
|
(send dc draw-text str start-x start-y)))))
|
|
(plot-setup-y-axis-marking ps))
|
|
|
|
;; draw axis labels
|
|
(send dc set-font (plot-setup-axis-label-font ps))
|
|
(let-values (((x-label-width x1 x2 x3)
|
|
(send dc get-text-extent
|
|
(plot-setup-x-axis-label ps)
|
|
(plot-setup-axis-label-font ps) #f 0)))
|
|
(send dc draw-text
|
|
(plot-setup-x-axis-label ps)
|
|
(- (+ side-space (* .5 (- canvas-width side-space))) (* .5 x-label-width))
|
|
(- canvas-height label-height)))
|
|
(let-values (((y-label-width y1 y2 y3)
|
|
(send dc get-text-extent
|
|
(plot-setup-y-axis-label ps)
|
|
(plot-setup-axis-label-font ps) #f 0)))
|
|
(draw-text-sideways dc (plot-setup-y-axis-label ps)
|
|
0
|
|
(- (* .5 (- canvas-height bottom-space))
|
|
(* .5 y-label-width))
|
|
(plot-setup-axis-label-font ps)
|
|
#f
|
|
0))
|
|
|
|
;; draw-grid
|
|
(cond
|
|
((plot-setup-grid? ps)
|
|
(send dc set-pen (plot-setup-grid-pen ps))
|
|
(for-each (lambda (x)
|
|
(send dc draw-lines
|
|
(map transform-point
|
|
(list (make-object point% x my)
|
|
(make-object point% x My)))))
|
|
(plot-setup-x-axis-marking ps))
|
|
(for-each (lambda (y)
|
|
(send dc draw-lines
|
|
(map transform-point
|
|
(list (make-object point% mx y)
|
|
(make-object point% Mx y)))))
|
|
(plot-setup-y-axis-marking ps))))
|
|
|
|
;; draw data
|
|
(for-each
|
|
(lambda (data)
|
|
(send dc set-pen (data-set-pen data))
|
|
(cond
|
|
((data-set-connected? data)
|
|
(send dc draw-lines (map transform-point (data-set-points data))))
|
|
(else
|
|
(for-each
|
|
(lambda (p)
|
|
(let ((tp (transform-point p)))
|
|
(send dc draw-point (send tp get-x) (send tp get-y))))
|
|
(data-set-points data)))))
|
|
data-sets)))))))
|
|
)
|