355 lines
12 KiB
Racket
355 lines
12 KiB
Racket
(module view mzscheme
|
|
(require plot/plplot plot/math mzlib/class mzlib/file
|
|
racket/draw racket/snip
|
|
mzlib/math)
|
|
|
|
;; including suggested fix from Doug Williams
|
|
|
|
; macro for creating a field in a class with a getter and a setter
|
|
(define-syntax (fields-with-accessors stx)
|
|
(define (join-identifier prefix ident)
|
|
(datum->syntax-object
|
|
ident
|
|
(string->symbol (string-append (symbol->string prefix )(symbol->string (syntax-e ident)))) ))
|
|
(syntax-case stx ()
|
|
[(_ (field init) ... )
|
|
(let ((accessors (map (lambda (id) (join-identifier 'get- id)) (syntax-e #'(field ...))))
|
|
(setters (map (lambda (id) (join-identifier 'set- id)) (syntax-e #'(field ...)))))
|
|
(with-syntax (((accessor ... ) accessors)
|
|
((setter ...) setters))
|
|
#'(fields-with-accessors-helper (accessor setter field init) ...)))]))
|
|
|
|
; for accessors
|
|
(define-syntax fields-with-accessors-helper
|
|
(syntax-rules ()
|
|
[(_ (accessor setter field init) ...)
|
|
(begin
|
|
(init-field (field init)) ...
|
|
(define (accessor) field) ...
|
|
(define (setter val) (set! field val)) ...) ]))
|
|
|
|
|
|
; base class for a plot view
|
|
;
|
|
(define plot-view%
|
|
(class* image-snip% ()
|
|
(public
|
|
set-line-color
|
|
set-line-width
|
|
set-plot-environment
|
|
reset-to-default
|
|
get-x-min
|
|
get-x-max
|
|
get-y-min
|
|
get-y-max
|
|
|
|
get-x-label
|
|
get-y-label
|
|
get-title
|
|
start-plot
|
|
finish-plot
|
|
|
|
get-renderer
|
|
|
|
get-height
|
|
get-width)
|
|
|
|
(init-field
|
|
renderer)
|
|
|
|
(fields-with-accessors
|
|
(height 300)
|
|
(width 400)
|
|
(out-file #f) ;; if file is not #f, keep the file
|
|
(x-min -5)
|
|
(x-max 5)
|
|
(y-min -5)
|
|
(y-max 5)
|
|
(x-label "X axis")
|
|
(y-label "Y axis")
|
|
(title "")
|
|
(device 'dc)
|
|
(fgcolor '(0 0 0))
|
|
(bgcolor '(255 255 255))
|
|
(lncolor '(255 0 0)))
|
|
|
|
(define x-size 400)
|
|
(define y-size 300)
|
|
(define bitmap (make-bitmap width height))
|
|
|
|
(inherit
|
|
set-bitmap
|
|
load-file)
|
|
|
|
(define (get-renderer) renderer)
|
|
|
|
; set the initial environment
|
|
(define (set-plot-environment x-min x-max y-min y-max just other)
|
|
(pl-set-plot-environment x-min x-max y-min y-max just other))
|
|
|
|
; changes the *initial* colormap to match the colors
|
|
; this should probably be done dynamically
|
|
(define (init-colors)
|
|
(apply pl-set-colormap0-index 0 bgcolor) ; 0 to white
|
|
(apply pl-set-colormap0-index 1 fgcolor) ; 1 to black
|
|
(apply pl-set-colormap0-index 15 lncolor)) ; 15 to red
|
|
|
|
; these are the colors to whitch the plot will be initialzed
|
|
(define colors '((white 0) (black 1) (yellow 2) (green 3)
|
|
(aqua 4) (pink 5) (wheat 6) (grey 7)
|
|
(brown 8) (blue 9) (violet 10) (cyan 11)
|
|
(turquoise 12) (magenta 13) (salmon 14) (red 15)))
|
|
|
|
; set-line-width : number -> nothing
|
|
(define (set-line-width width) (pl-set-line-width width))
|
|
|
|
; reset-to-default : void
|
|
; resets some of the state to default
|
|
(define (reset-to-default)
|
|
(init-colors)
|
|
(set-line-color 'black)
|
|
(set-line-width 0))
|
|
|
|
;set-line-color : symbol -> nothing
|
|
(define (set-line-color color)
|
|
(let ((index (cond [(assq color colors ) => cadr]
|
|
[else (error (format "color ~v not found" color))])))
|
|
(pl-select-colormap0-index index)))
|
|
|
|
; start the plot
|
|
; does housekeeping/setup for plplot
|
|
(define (start-plot)
|
|
(cond
|
|
[(eq? device 'dc)
|
|
(init-colors)
|
|
(pl-setup-page width height)
|
|
(pl-set-device "dc")
|
|
(let ([dev (pl-init-plot)])
|
|
(init-dev! dev (let ([dc (make-object bitmap-dc% bitmap)])
|
|
(send dc set-origin 0 height)
|
|
(send dc set-scale 1 -1)
|
|
(send dc set-smoothing 'aligned)
|
|
(send dc set-background (apply make-object color% bgcolor))
|
|
(send dc clear)
|
|
(new (class object%
|
|
(define/public (draw-line x1 y1 x2 y2)
|
|
(send dc draw-line x1 y1 x2 y2))
|
|
(define/public (draw-lines points)
|
|
(send dc draw-lines points))
|
|
(define/public (draw-polygon points)
|
|
(send dc draw-polygon points))
|
|
(define/public (set-width n)
|
|
(send dc set-pen (send (send dc get-pen) get-color) n 'solid))
|
|
(define/public (set-index-color i)
|
|
(let ([color (case i
|
|
[(0) (apply make-object color% bgcolor)]
|
|
[(1) (apply make-object color% fgcolor)]
|
|
[(15) (apply make-object color% lncolor)]
|
|
[else (make-object color% (symbol->string (car (list-ref colors i))))])])
|
|
(send dc set-pen color (send (send dc get-pen) get-width) 'solid)
|
|
(send dc set-brush color 'solid)))
|
|
(define/public (set-rgb-color r g b)
|
|
(let ([color (make-object color% r g b)])
|
|
(send dc set-pen color (send (send dc get-pen) get-width) 'solid)
|
|
(send dc set-brush color 'solid)))
|
|
(define/public (start-page) (void))
|
|
(define/public (end-page) (void))
|
|
(define/public (end-doc)
|
|
(send dc set-bitmap #f))
|
|
(super-new))))))
|
|
(set-line-color 'black)
|
|
(set-line-width 0)]
|
|
[else
|
|
(error "Incorrect device specified")]))
|
|
|
|
; finish the plot.. loads the file
|
|
(define (finish-plot)
|
|
(cond
|
|
[(eq? device 'dc)
|
|
(pl-finish-plot)
|
|
(when out-file
|
|
(send bitmap save-file out-file 'png))
|
|
(set-bitmap bitmap)]
|
|
[else
|
|
(error "Incorrect device specified")]))
|
|
|
|
(super-instantiate ())))
|
|
|
|
;; a 2d plot view
|
|
(define 2d-view%
|
|
(class* plot-view% ()
|
|
(public
|
|
set-labels
|
|
plot-y-errors
|
|
plot-vector
|
|
plot-vectors
|
|
plot-points
|
|
plot-line
|
|
plot-contours
|
|
plot-shades
|
|
fill)
|
|
|
|
; set-labels : string string string -> nothing
|
|
; sets the x, y and title lables
|
|
(define (set-labels x-label y-label title)
|
|
(pl-set-labels x-label y-label title))
|
|
|
|
; plot-contours: listoflistof number, listof-number, listof-number, listof-number
|
|
(define (plot-contours z x-vals y-vals levels)
|
|
(pl-2d-contour-plot z x-vals y-vals levels))
|
|
|
|
; plot-shades: listoflistof number, listof-number, listof-number, listof-number
|
|
(define (plot-shades z x-vals y-vals levels)
|
|
(pl-2d-shade-plot z x-vals y-vals levels))
|
|
|
|
; plot-line : (listof vector) -> void
|
|
; plots a line with the given points
|
|
(define (plot-line points)
|
|
(pl-plot-line (length points)
|
|
(map vector-x points)
|
|
(map vector-y points)))
|
|
|
|
; plot-points : (listof vector) -> void
|
|
; plots given points with a . symbol
|
|
(define (plot-points points sym)
|
|
(pl-plot-points (length points)
|
|
(map vector-x points)
|
|
(map vector-y points)
|
|
sym))
|
|
|
|
(define v-head-ratio 1/4) ; size of the vector head
|
|
(define rot (* 5 pi 1/6))
|
|
|
|
; plot-vectors: (listof (list vector vector)) - > void
|
|
(define (plot-vectors from delta)
|
|
(for-each (lambda (f d) (send this plot-vector f d)) from delta))
|
|
|
|
; plot-vector : vector vector -> nothing
|
|
(define (plot-vector from delta)
|
|
(unless (= 0 (vector-magnitude delta))
|
|
(let* ((x (vector-x from)) (x2 (+ x (vector-x delta)))
|
|
(y (vector-y from)) (y2 (+ y (vector-y delta)))
|
|
(ang (atan (vector-y delta) (vector-x delta)))
|
|
(len (vector-magnitude delta))
|
|
(x3 (+ x2 (* len v-head-ratio (cos (+ ang rot)))))
|
|
(x4 (+ x2 (* len v-head-ratio (cos (- ang rot)))))
|
|
(y3 (+ y2 (* len v-head-ratio (sin (+ ang rot)))))
|
|
(y4 (+ y2 (* len v-head-ratio (sin (- ang rot))))))
|
|
(plot-line (list from
|
|
(vector x2 y2)
|
|
(vector x3 y3)
|
|
(vector x4 y4)
|
|
(vector x2 y2))))))
|
|
|
|
; fill : (list-of number) (list-of number) -> void
|
|
(define (fill xs ys)
|
|
(pl-fill xs ys))
|
|
|
|
; plot-y-errors (listof (vector x y-min y-max)) ->nothing
|
|
; plots y error bars given a vector containing the x y and z (error magnitude) points
|
|
(define (plot-y-errors errlist)
|
|
(pl-y-error-bars (length errlist) (map vector-x errlist) (map vector-y errlist) (map vector-z errlist)))
|
|
|
|
|
|
|
|
(inherit start-plot set-plot-environment finish-plot
|
|
get-x-min get-x-max get-y-min get-y-max get-renderer
|
|
get-x-label get-y-label get-title)
|
|
(define (plot)
|
|
(start-plot)
|
|
(set-plot-environment (get-x-min) (get-x-max) (get-y-min) (get-y-max) 0 1)
|
|
(set-labels (get-x-label) (get-y-label) (get-title))
|
|
(with-handlers ((exn? (lambda (ex) (finish-plot) (raise ex))))
|
|
((get-renderer) this))
|
|
(finish-plot)
|
|
this)
|
|
|
|
(super-instantiate ())
|
|
(plot)))
|
|
|
|
; 3d view
|
|
; for making meshes and stuff
|
|
|
|
(define 3d-view%
|
|
(class* plot-view% ()
|
|
(public
|
|
plot-polygon
|
|
plot-line
|
|
plot-surface
|
|
plot-3dmesh
|
|
get-z-min
|
|
get-z-max
|
|
get-alt
|
|
get-az)
|
|
|
|
|
|
(fields-with-accessors
|
|
(z-min -5)
|
|
(z-max 5)
|
|
(alt 30)
|
|
(az 45)
|
|
(z-label "Z-Axis"))
|
|
|
|
; set-labels : string string string -> nothing
|
|
; sets the x, y and title lables
|
|
(define (set-labels x-label y-label title)
|
|
(pl-set-labels x-label y-label title))
|
|
|
|
; define the 3d world
|
|
(define (world3d x y z xmin xmax ymin ymax zmin zmax alt az)
|
|
(pl-world-3d x y z xmin xmax ymin ymax zmin zmax alt az))
|
|
|
|
; set up the axies box
|
|
(define (box3d
|
|
xopts xlabel xticks nxsub
|
|
yopts ylabel yticks nysub
|
|
zopts zlabel zticks nzsub)
|
|
(pl-box3 xopts xlabel xticks nxsub
|
|
yopts ylabel yticks nysub
|
|
zopts zlabel zticks nzsub))
|
|
|
|
; draw a simple 3d surface plot
|
|
(define (plot-surface x y z)
|
|
(pl-plot3d x y z))
|
|
|
|
; plot-3dmesh
|
|
(define (plot-3dmesh x y z lines? colored? contours? sides? levels)
|
|
(pl-mesh3dc x y z lines? colored? contours? sides? levels))
|
|
|
|
(inherit start-plot set-plot-environment finish-plot get-x-min
|
|
get-x-max get-y-min get-y-max get-renderer get-x-label get-y-label
|
|
get-title)
|
|
|
|
(define (plot)
|
|
(start-plot)
|
|
(set-plot-environment -1 1 -1 1 0 -2)
|
|
(world3d 1 1 1 (get-x-min) (get-x-max) (get-y-min) (get-y-max) z-min z-max alt az)
|
|
(box3d
|
|
"bnstu" (get-x-label) 0 0
|
|
"bnstu" (get-y-label) 0 0
|
|
"bnstu" z-label 0 0)
|
|
(set-labels "" "" (get-title))
|
|
(with-handlers ((exn? (lambda (ex) (finish-plot) (raise ex))))
|
|
((get-renderer) this))
|
|
(finish-plot)
|
|
this)
|
|
|
|
; plot a polygon in 3 space
|
|
(define (plot-polygon x y z draw ifc)
|
|
(pl-poly3 x y z draw ifc))
|
|
|
|
|
|
; plot a line in 3 space
|
|
; x y and z are lists of equal length
|
|
(define (plot-line x y z)
|
|
(pl-line3 x y z))
|
|
|
|
|
|
(super-instantiate ())
|
|
(plot)))
|
|
|
|
(provide
|
|
plot-view%
|
|
2d-view%
|
|
3d-view%))
|