409 lines
13 KiB
Racket
409 lines
13 KiB
Racket
#lang racket/base
|
|
(require mzlib/etc
|
|
racket/list
|
|
ffi/unsafe
|
|
racket/runtime-path
|
|
racket/class
|
|
(for-syntax racket/base))
|
|
|
|
(define-runtime-path plplot-path '(so "libplplot"))
|
|
(define-runtime-path font-dir "fonts")
|
|
|
|
(define libplplot (ffi-lib plplot-path))
|
|
|
|
(define plplotlibdir (get-ffi-obj "plplotLibDir" libplplot _string))
|
|
|
|
;; set the lib dir to contain the fonts:
|
|
(let ([path font-dir])
|
|
;; free current pointer, if any:
|
|
(let ([p (get-ffi-obj "plplotLibDir" libplplot _pointer)])
|
|
(when p (free p)))
|
|
;; install new value:
|
|
(set-ffi-obj! "plplotLibDir" libplplot _bytes
|
|
;; malloc the string, since the GC won't see the static variable:
|
|
(let* ([gced-bytes (path->bytes path)]
|
|
[len (bytes-length gced-bytes)]
|
|
[p (malloc (add1 len) 'raw)]
|
|
[malloced-bytes (make-sized-byte-string p len)])
|
|
(bytes-copy! malloced-bytes 0 gced-bytes)
|
|
;; set nul terminator:
|
|
(ptr-set! p _byte len 0)
|
|
malloced-bytes)))
|
|
|
|
(define-cstruct _dc_Dev
|
|
([user_data _pointer]
|
|
[drawLine _fpointer]
|
|
[drawLines _fpointer]
|
|
[fillPoly _fpointer]
|
|
[setWidth _fpointer]
|
|
[setColor _fpointer]
|
|
[setColorRGB _fpointer]
|
|
[startPage _fpointer]
|
|
[endPage _fpointer]
|
|
[endDoc _fpointer]))
|
|
|
|
(define _PLINT _int)
|
|
|
|
(define _plflt _double*)
|
|
(define _plint _int)
|
|
|
|
;; While an array generated from a list is passed to an
|
|
;; plot library function, we might perform a GC through
|
|
;; the back-end drawing operation. So, arrays must be
|
|
;; allocated as non-moving objects
|
|
(define-fun-syntax _list/still
|
|
(lambda (stx)
|
|
(syntax-case stx (i)
|
|
[(_ i ty) #'(_list/still i ty 'atomic-interior)]
|
|
[(_ i ty mode)
|
|
#'(type: _pointer
|
|
pre: (x => (list->cblock/mode x ty mode)))])))
|
|
|
|
(define-fun-syntax _matrix-of
|
|
(lambda (stx)
|
|
(syntax-case stx (i)
|
|
[(_ ty)
|
|
#'(_list/still i (_list/still i ty) 'interior)])))
|
|
|
|
(define (list->cblock/mode l type mode)
|
|
(if (null? l)
|
|
#f ; null => NULL
|
|
(let ([cblock (malloc (length l) type mode)])
|
|
(let loop ([l l] [i 0])
|
|
(unless (null? l)
|
|
(ptr-set! cblock type i (car l))
|
|
(loop (cdr l) (add1 i))))
|
|
cblock)))
|
|
|
|
(define-syntax define*
|
|
(syntax-rules ()
|
|
[(_ (name . args) body ...)
|
|
(begin (provide name) (define (name . args) body ...))]
|
|
[(_ name expr)
|
|
(begin (provide name) (define name expr))]))
|
|
|
|
(define* pl-setup-page
|
|
(get-ffi-obj "c_plspage" libplplot
|
|
(_fun (xp : _plflt = 0.0)
|
|
(yp : _plflt = 0.0)
|
|
(xleng : _plint)
|
|
(yleng : _plint)
|
|
(xoff : _plint = 0)
|
|
(yoff : _plint = 0)
|
|
-> _void)))
|
|
|
|
(define* pl-set-device
|
|
(get-ffi-obj "c_plsdev" libplplot (_fun _string -> _void)))
|
|
|
|
(define* pl-set-output-file
|
|
(get-ffi-obj "c_plsfnam" libplplot (_fun _string -> _void)))
|
|
|
|
(define* pl-init-plot
|
|
(get-ffi-obj "c_plinit" libplplot (_fun -> _dc_Dev-pointer)))
|
|
|
|
(define* pl-finish-plot
|
|
(get-ffi-obj "c_plend" libplplot (_fun -> _void)))
|
|
|
|
(define* pl-set-plot-environment
|
|
(get-ffi-obj "c_plenv" libplplot
|
|
(_fun _plflt _plflt _plflt _plflt _plint _plint -> _void)))
|
|
|
|
(define* pl-set-labels
|
|
(get-ffi-obj "c_pllab" libplplot
|
|
(_fun _string _string _string -> _void)))
|
|
|
|
(define* pl-plot-line
|
|
(get-ffi-obj "c_plline" libplplot
|
|
(_fun _plint (x : (_list/still i _plflt)) (y : (_list/still i _plflt)) -> _void)))
|
|
|
|
(define* pl-plot-segment
|
|
(get-ffi-obj "c_pljoin" libplplot
|
|
(_fun _plflt _plflt _plflt _plflt -> _void)))
|
|
|
|
(define* pl-set-background-color
|
|
(get-ffi-obj "c_plscolbg" libplplot
|
|
(_fun _plint _plint _plint -> _void)))
|
|
|
|
|
|
(define* pl-select-colormap0-index
|
|
(get-ffi-obj "c_plcol0" libplplot
|
|
(_fun _plint -> _void)))
|
|
|
|
(define* pl-set-colormap0-index
|
|
(get-ffi-obj "c_plscol0" libplplot
|
|
(_fun _plint _plint _plint _plint -> _void)))
|
|
|
|
(define* pl-set-line-width
|
|
(get-ffi-obj "c_plwid" libplplot
|
|
(_fun _plint -> _void)))
|
|
|
|
(define* pl-write-text
|
|
(get-ffi-obj "c_plptex" libplplot
|
|
(_fun _plflt _plflt _plflt _plflt _plflt _string -> _void)))
|
|
|
|
;;(define* pl-2d-countour-plot ...)
|
|
;;(define* pl-2d-shade-plot ...)
|
|
|
|
(define* pl-x-error-bars
|
|
(get-ffi-obj "c_plerrx" libplplot
|
|
(_fun _plint (_list/still i _plflt)
|
|
(_list/still i _plflt)
|
|
(_list/still i _plflt) -> _void)))
|
|
|
|
(define* pl-y-error-bars
|
|
(get-ffi-obj "c_plerry" libplplot
|
|
(_fun _plint (_list/still i _plflt)
|
|
(_list/still i _plflt)
|
|
(_list/still i _plflt) -> _void)))
|
|
|
|
(define* pl-plot-points
|
|
(get-ffi-obj "c_plpoin" libplplot
|
|
(_fun _plint (x : (_list/still i _plflt)) (y : (_list/still i _plflt)) _plint
|
|
-> _void)))
|
|
|
|
(define* pl-fill
|
|
(get-ffi-obj "c_plfill" libplplot
|
|
(_fun (n : _plint = (length x-values))
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
-> _void)))
|
|
|
|
(define* pl-world-3d
|
|
(get-ffi-obj "c_plw3d" libplplot
|
|
(_fun
|
|
_plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt _plflt
|
|
->
|
|
_void)))
|
|
|
|
;; bit-masks for some of the functions..
|
|
(define-values (DRAW_LINEX DRAW_LINEY MAG_COLOR BASE_CONT TOP_CONT SURF_CONT DRAW_SIDES DRAW_FACETED MESH)
|
|
(apply values (build-list 9 (lambda (s) (arithmetic-shift 1 s)))))
|
|
|
|
(define DRAW_LINEXY (bitwise-ior DRAW_LINEX DRAW_LINEY))
|
|
|
|
|
|
(define* pl-plot3d
|
|
(get-ffi-obj "c_plot3d" libplplot
|
|
(_fun
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
(z-values : (_matrix-of _plflt))
|
|
(nx : _int = (length x-values))
|
|
(ny : _int = (length y-values))
|
|
(draw-opt1 : _int = DRAW_LINEXY)
|
|
(draw-opt2 : _int = 0)
|
|
-> _void))) ;; these are documented in the plplot ref manual, and will be obseleted.
|
|
|
|
(define* pl-mesh3d
|
|
(get-ffi-obj "c_plot3d" libplplot
|
|
(_fun
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
(z-values : (_matrix-of _plflt))
|
|
(nx : _int = (length x-values))
|
|
(ny : _int = (length y-values))
|
|
(draw-opt1 : _int = DRAW_LINEXY)
|
|
-> _void)))
|
|
|
|
; ;; this function needs to go.
|
|
; (define* pl-plot-points
|
|
; (get-ffi-obj "c_plpoin" libplplot
|
|
; (_fun
|
|
; (nx : _int = (length x-values))
|
|
; (x-values : (_list/still i _plflt))
|
|
; (y-values : (_list/still i _plflt))
|
|
; (code : _int))))
|
|
|
|
(define* pl-box3
|
|
(get-ffi-obj "c_plbox3" libplplot
|
|
(_fun
|
|
(x-ops : _string) (x-title : _string) (x-spacing : _plflt) (x-ticks : _int)
|
|
(y-ops : _string) (y-title : _string) (y-spacing : _plflt) (y-ticks : _int)
|
|
(z-ops : _string) (z-title : _string) (z-spacing : _plflt) (z-ticks : _int)
|
|
-> _void)))
|
|
|
|
(define* pl-line3
|
|
(get-ffi-obj "c_plline3" libplplot
|
|
(_fun
|
|
(n-points : _int = (length x-values))
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
(z-values : (_list/still i _plflt))
|
|
-> _void)))
|
|
|
|
|
|
(define* pl-poly3
|
|
(get-ffi-obj "c_plpoly3" libplplot
|
|
(_fun
|
|
(n-points : _int = (length x-values))
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
(z-values : (_list/still i _plflt))
|
|
(draw-mask : (_list/still i _int))
|
|
(direction : _int)
|
|
-> _void)))
|
|
|
|
;; need the CStruct PLcGrid ;
|
|
;; PLFLT *xg, *yg, *zg;
|
|
;; PLINT nx, ny, nz;
|
|
(define-cstruct _PLcGrid ((xg _pointer)
|
|
(yg _pointer)
|
|
(zg _pointer)
|
|
(nx _int)
|
|
(ny _int)
|
|
(nz _int)))
|
|
|
|
(define pl-2d-contour-plot-int
|
|
(get-ffi-obj "c_plcont" libplplot
|
|
(_fun
|
|
(matrix : (_matrix-of _plflt))
|
|
(nx : _int = (PLcGrid-nx grid))
|
|
(ny : _int = (PLcGrid-ny grid))
|
|
(t1 : _plint = 1)
|
|
(t2 : _int = (PLcGrid-nx grid))
|
|
(t3 : _plint = 1)
|
|
(t4 : _int = (PLcGrid-ny grid))
|
|
(levels : (_list/still i _plflt))
|
|
(nlevels : _int = (length levels))
|
|
(pltr : _fpointer = (get-ffi-obj "pltr1" libplplot _fpointer))
|
|
(grid : _PLcGrid-pointer)
|
|
-> _void)))
|
|
|
|
(define* (pl-2d-contour-plot z-vals x-vals y-vals levels)
|
|
(let ((grid-obj (make-PLcGrid (list->cblock x-vals _plflt) (list->cblock y-vals _plflt) #f
|
|
(length x-vals) (length y-vals) 0)))
|
|
(pl-2d-contour-plot-int z-vals levels grid-obj)))
|
|
|
|
|
|
|
|
(define pl-2d-shade-plot-int
|
|
(get-ffi-obj "c_plshades" libplplot
|
|
(_fun
|
|
(matrix : (_matrix-of _plflt))
|
|
(nx : _int = (PLcGrid-nx grid))
|
|
(ny : _int = (PLcGrid-ny grid))
|
|
(null-val : _pointer = #f)
|
|
(x_min : _plflt = 0)
|
|
(x_max : _plflt = 0)
|
|
(y_min : _plflt = 0)
|
|
(y_max : _plflt = 0)
|
|
(levels : (_list/still i _plflt))
|
|
(nlevels : _int = (length levels))
|
|
(fill_width : _int = 1)
|
|
(cont_col : _int = 1)
|
|
(cont_width : _int = 0)
|
|
(fill_fun : _fpointer = (get-ffi-obj "c_plfill" libplplot _fpointer))
|
|
(rectan : _int = 1)
|
|
(pltr : _fpointer = (get-ffi-obj "pltr1" libplplot _fpointer))
|
|
(grid : _PLcGrid-pointer)
|
|
-> _void)))
|
|
|
|
(define* (pl-2d-shade-plot z-vals x-vals y-vals levels)
|
|
;; this can prolly be inlined above..
|
|
(let ((grid-obj (make-PLcGrid (list->cblock x-vals _plflt) (list->cblock y-vals _plflt) #f
|
|
(length x-vals) (length y-vals) 0)))
|
|
(pl-2d-shade-plot-int z-vals levels grid-obj)))
|
|
|
|
|
|
;; set up color map numbers
|
|
(define plscmap1n
|
|
(get-ffi-obj "c_plscmap1n" libplplot
|
|
(_fun _int -> _void)))
|
|
|
|
;; set up the map
|
|
(define plscmap1l
|
|
(get-ffi-obj "c_plscmap1l" libplplot
|
|
(_fun
|
|
(itype : _plint)
|
|
(npts : _int = (length intencity))
|
|
(intencity : (_list/still i _plflt))
|
|
(coord1 : (_list/still i _plflt))
|
|
(coord2 : (_list/still i _plflt))
|
|
(coord3 : (_list/still i _plflt))
|
|
(rev : _pointer = #f)
|
|
-> _void)))
|
|
|
|
(define pl-mesh3dc-int
|
|
(get-ffi-obj "c_plmeshc" libplplot
|
|
(_fun
|
|
(x-values : (_list/still i _plflt))
|
|
(y-values : (_list/still i _plflt))
|
|
(z-values : (_matrix-of _plflt))
|
|
(x-len : _int = (length x-values))
|
|
(y-len : _int = (length y-values))
|
|
(opts : _int)
|
|
(levels : (_list/still i _plflt))
|
|
(n-levels : _int = (length levels))
|
|
-> _void)))
|
|
|
|
(define* (pl-mesh3dc x-vals y-vals z-vals contours? lines? colored? sides? levels)
|
|
(let ((opts (foldl
|
|
(lambda (mask use? current) (bitwise-ior current (if use? mask 0)))
|
|
0
|
|
(list DRAW_LINEXY MAG_COLOR BASE_CONT DRAW_SIDES)
|
|
(list contours? lines? colored? sides?))))
|
|
(plscmap1n 256)
|
|
(plscmap1l 0 '(0.0 1.0) '(240 0) '(.6 .6) '(.8 .8))
|
|
(pl-mesh3dc-int x-vals y-vals z-vals opts levels)))
|
|
|
|
(define (dc-draw-line dest x1 y1 x2 y2)
|
|
(send (ptr-ref dest _racket) draw-line x1 y1 x2 y2))
|
|
(define (dc-draw-multi dest xs ys n go)
|
|
(let ([xs (cast xs _pointer (_vector o _short n))]
|
|
[ys (cast ys _pointer (_vector o _short n))])
|
|
(go (ptr-ref dest _racket)
|
|
(for/list ([x (in-vector xs)]
|
|
[y (in-vector ys)])
|
|
(cons x y)))))
|
|
(define (dc-draw-lines dest xs ys n)
|
|
(dc-draw-multi dest xs ys n
|
|
(lambda (dc l) (send dc draw-lines l))))
|
|
(define (dc-fill-poly dest xs ys n)
|
|
(dc-draw-multi dest xs ys n
|
|
(lambda (dc l) (send dc draw-polygon l))))
|
|
(define (dc-set-width dest w)
|
|
(send (ptr-ref dest _racket) set-width w))
|
|
(define (dc-set-color dest index)
|
|
(send (ptr-ref dest _racket) set-index-color index))
|
|
(define (dc-set-color/rgb dest r g b)
|
|
(send (ptr-ref dest _racket) set-rgb-color r g b))
|
|
(define (dc-start-page dest)
|
|
(send (ptr-ref dest _racket) start-page))
|
|
(define (dc-end-page dest)
|
|
(send (ptr-ref dest _racket) end-page))
|
|
(define (dc-end-doc dest)
|
|
(send (ptr-ref dest _racket) end-doc)
|
|
(free-immobile-cell dest))
|
|
|
|
(define draw_line (function-ptr dc-draw-line
|
|
(_fun _pointer _short _short _short _short -> _void)))
|
|
(define draw_lines (function-ptr dc-draw-lines
|
|
(_fun _pointer _pointer _pointer _PLINT -> _void)))
|
|
(define fill_poly (function-ptr dc-fill-poly
|
|
(_fun _pointer _pointer _pointer _PLINT -> _void)))
|
|
(define set_width (function-ptr dc-set-width
|
|
(_fun _pointer _int -> _void)))
|
|
(define set_color (function-ptr dc-set-color
|
|
(_fun _pointer _short -> _void)))
|
|
(define set_color_rgb (function-ptr dc-set-color/rgb
|
|
(_fun _pointer _short _short _short -> _void)))
|
|
(define start_page (function-ptr dc-start-page
|
|
(_fun _pointer -> _void)))
|
|
(define end_page (function-ptr dc-end-page
|
|
(_fun _pointer -> _void)))
|
|
(define end_doc (function-ptr dc-end-doc
|
|
(_fun _pointer -> _void)))
|
|
|
|
(provide init-dev!)
|
|
(define (init-dev! dev obj)
|
|
(set-dc_Dev-user_data! dev (malloc-immobile-cell obj))
|
|
(set-dc_Dev-drawLine! dev draw_line)
|
|
(set-dc_Dev-drawLines! dev draw_lines)
|
|
(set-dc_Dev-fillPoly! dev fill_poly)
|
|
(set-dc_Dev-setWidth! dev set_width)
|
|
(set-dc_Dev-setColor! dev set_color)
|
|
(set-dc_Dev-setColorRGB! dev set_color_rgb)
|
|
(set-dc_Dev-startPage! dev start_page)
|
|
(set-dc_Dev-endPage! dev end_page)
|
|
(set-dc_Dev-endDoc! dev end_doc))
|