347 lines
11 KiB
Scheme
347 lines
11 KiB
Scheme
(module view mzscheme
|
|
(require
|
|
(lib "plplot.ss" "plot")
|
|
(lib "math.ss" "plot")
|
|
(lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "math.ss")
|
|
;(lib "4.ss" "srfi")
|
|
)
|
|
|
|
;; 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 'png)
|
|
(fgcolor '( 0 0 0))
|
|
(bgcolor '(255 255 255))
|
|
(lncolor '(255 0 0 )))
|
|
|
|
(define bitmap #f)
|
|
(define x-size 400)
|
|
(define y-size 300)
|
|
|
|
(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 (string-append "color \"" color "\" not found"))])))
|
|
(pl-select-colormap0-index index)))
|
|
|
|
; start the plot
|
|
; does housekeeping/setup for plplot
|
|
(define (start-plot)
|
|
(cond
|
|
[(eq? device 'png)
|
|
(set! bitmap (if out-file
|
|
(build-path out-file)
|
|
(make-temporary-file)))
|
|
(init-colors)
|
|
(pl-setup-page width height)
|
|
(pl-set-device "png")
|
|
(pl-set-output-file (path->string bitmap))
|
|
(pl-init-plot)]
|
|
; [(eq? device 'mem)
|
|
; (init-colors)
|
|
; (set! bitmap (make-u8vector (* x-size y-size 4) 255))
|
|
; (pl-setup-memory x-size y-size bitmap)
|
|
; (pl-set-device "mem")
|
|
; (pl-init-plot)]
|
|
[else
|
|
(error "Incorrect device specified")]))
|
|
|
|
; finish the plot.. loads the file
|
|
(define (finish-plot)
|
|
(cond
|
|
[(eq? device 'png)
|
|
(pl-finish-plot)
|
|
(load-file bitmap)
|
|
(or out-file (delete-file bitmap))]
|
|
; [(eq? device 'mem)
|
|
; (pl-finish-plot)
|
|
; (set-bitmap (bits->bitmap-dc% bitmap))]
|
|
[else
|
|
(error "Incorrect device specified")]))
|
|
|
|
;(define (bits->bitmap-dc% bitmap)
|
|
; (let ((bmdc (instantiate bitmap-dc% () (bitmap (make-object bitmap% x-size y-size #f))))
|
|
; (result-string (u8vec->scheme-string bitmap)))
|
|
; (send bmdc set-argb-pixels 0 0 x-size y-size result-string)
|
|
; (begin0
|
|
; (send bmdc get-bitmap)
|
|
; (send bmdc set-bitmap #f))))
|
|
|
|
(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
|
|
2d-view%
|
|
3d-view%))
|