diff --git a/collects/plot/plplot.rkt b/collects/plot/plplot.rkt index 7ef52d4175..304b684334 100644 --- a/collects/plot/plplot.rkt +++ b/collects/plot/plplot.rkt @@ -47,16 +47,33 @@ (define _plflt _double*) (define _plint _int) -(define (_list-of type . len?) - (let ([len (and (pair? len?) (car len?))]) - (make-ctype _pointer - (lambda (l) (list->cblock l type)) - (if len - (lambda (b) (cblock->list b type len)) - (lambda (b) (error "this list type does not specify a size")))))) +;; 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 (_matrix-of type) - (_list-of (_list-of type))) +(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 () @@ -97,7 +114,7 @@ (define* pl-plot-line (get-ffi-obj "c_plline" libplplot - (_fun _plint (x : (_list i _plflt)) (y : (_list i _plflt)) -> _void))) + (_fun _plint (x : (_list/still i _plflt)) (y : (_list/still i _plflt)) -> _void))) (define* pl-plot-segment (get-ffi-obj "c_pljoin" libplplot @@ -129,26 +146,26 @@ (define* pl-x-error-bars (get-ffi-obj "c_plerrx" libplplot - (_fun _plint (_list i _plflt) - (_list i _plflt) - (_list i _plflt) -> _void))) + (_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 i _plflt) - (_list i _plflt) - (_list i _plflt) -> _void))) + (_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 i _plflt)) (y : (_list i _plflt)) _plint + (_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 i _plflt)) - (y-values : (_list i _plflt)) + (x-values : (_list/still i _plflt)) + (y-values : (_list/still i _plflt)) -> _void))) (define* pl-world-3d @@ -168,8 +185,8 @@ (define* pl-plot3d (get-ffi-obj "c_plot3d" libplplot (_fun - (x-values : (_list i _plflt)) - (y-values : (_list i _plflt)) + (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)) @@ -180,8 +197,8 @@ (define* pl-mesh3d (get-ffi-obj "c_plot3d" libplplot (_fun - (x-values : (_list i _plflt)) - (y-values : (_list i _plflt)) + (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)) @@ -193,8 +210,8 @@ ; (get-ffi-obj "c_plpoin" libplplot ; (_fun ; (nx : _int = (length x-values)) -; (x-values : (_list i _plflt)) -; (y-values : (_list i _plflt)) +; (x-values : (_list/still i _plflt)) +; (y-values : (_list/still i _plflt)) ; (code : _int)))) (define* pl-box3 @@ -209,9 +226,9 @@ (get-ffi-obj "c_plline3" libplplot (_fun (n-points : _int = (length x-values)) - (x-values : (_list i _plflt)) - (y-values : (_list i _plflt)) - (z-values : (_list i _plflt)) + (x-values : (_list/still i _plflt)) + (y-values : (_list/still i _plflt)) + (z-values : (_list/still i _plflt)) -> _void))) @@ -219,10 +236,10 @@ (get-ffi-obj "c_plpoly3" libplplot (_fun (n-points : _int = (length x-values)) - (x-values : (_list i _plflt)) - (y-values : (_list i _plflt)) - (z-values : (_list i _plflt)) - (draw-mask : (_list i _int)) + (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))) @@ -246,7 +263,7 @@ (t2 : _int = (PLcGrid-nx grid)) (t3 : _plint = 1) (t4 : _int = (PLcGrid-ny grid)) - (levels : (_list i _plflt)) + (levels : (_list/still i _plflt)) (nlevels : _int = (length levels)) (pltr : _fpointer = (get-ffi-obj "pltr1" libplplot _fpointer)) (grid : _PLcGrid-pointer) @@ -270,7 +287,7 @@ (x_max : _plflt = 0) (y_min : _plflt = 0) (y_max : _plflt = 0) - (levels : (_list i _plflt)) + (levels : (_list/still i _plflt)) (nlevels : _int = (length levels)) (fill_width : _int = 1) (cont_col : _int = 1) @@ -299,23 +316,23 @@ (_fun (itype : _plint) (npts : _int = (length intencity)) - (intencity : (_list i _plflt)) - (coord1 : (_list i _plflt)) - (coord2 : (_list i _plflt)) - (coord3 : (_list i _plflt)) + (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 i _plflt)) - (y-values : (_list i _plflt)) + (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 i _plflt)) + (levels : (_list/still i _plflt)) (n-levels : _int = (length levels)) -> _void))) diff --git a/collects/plot/view.rkt b/collects/plot/view.rkt index 93e9fd3e7b..288ad934a5 100644 --- a/collects/plot/view.rkt +++ b/collects/plot/view.rkt @@ -67,9 +67,9 @@ (y-label "Y axis") (title "") (device 'dc) - (fgcolor '( 0 0 0)) + (fgcolor '(0 0 0)) (bgcolor '(255 255 255)) - (lncolor '(255 0 0 ))) + (lncolor '(255 0 0))) (define x-size 400) (define y-size 300) @@ -120,13 +120,15 @@ (cond [(eq? device 'dc) (init-colors) - (pl-setup-page width height) + (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)) @@ -137,7 +139,11 @@ (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 (make-object color% (symbol->string (car (list-ref colors 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) @@ -148,7 +154,9 @@ (define/public (end-page) (void)) (define/public (end-doc) (send dc set-bitmap #f)) - (super-new))))))] + (super-new)))))) + (set-line-color 'black) + (set-line-width 0)] [else (error "Incorrect device specified")])) @@ -157,6 +165,8 @@ (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")])) diff --git a/collects/tests/plot/3d-mesh.png b/collects/tests/plot/3d-mesh.png index 301c594ab8..8ae38eff29 100644 Binary files a/collects/tests/plot/3d-mesh.png and b/collects/tests/plot/3d-mesh.png differ diff --git a/collects/tests/plot/contours.png b/collects/tests/plot/contours.png index 82db0d47f1..00ab85f239 100644 Binary files a/collects/tests/plot/contours.png and b/collects/tests/plot/contours.png differ diff --git a/collects/tests/plot/dashed-line.png b/collects/tests/plot/dashed-line.png index 78a4c0bf5e..83d4149a9e 100644 Binary files a/collects/tests/plot/dashed-line.png and b/collects/tests/plot/dashed-line.png differ diff --git a/collects/tests/plot/mix.png b/collects/tests/plot/mix.png index 730ac2e795..def30152c5 100644 Binary files a/collects/tests/plot/mix.png and b/collects/tests/plot/mix.png differ diff --git a/collects/tests/plot/red-identity.png b/collects/tests/plot/red-identity.png index 9e2b9f9e27..f2e29615c5 100644 Binary files a/collects/tests/plot/red-identity.png and b/collects/tests/plot/red-identity.png differ diff --git a/collects/tests/plot/run-tests.rkt b/collects/tests/plot/run-tests.rkt index b273c4c054..680d9433b2 100755 --- a/collects/tests/plot/run-tests.rkt +++ b/collects/tests/plot/run-tests.rkt @@ -3,7 +3,8 @@ exec gracket "$0" "$@" |# #lang scheme -(require plot file/md5 scheme/runtime-path) +(require plot file/md5 scheme/runtime-path + racket/draw) (define-runtime-path here "./") @@ -18,14 +19,30 @@ exec gracket "$0" "$@" [expected-file-name (build-path here (string-append file-name ".png"))]) (plot args ... #:out-file result-file-name) - ;; WILL COMPARE by MD5 hash. (printf "testing \"~a\" ... " description) - (if (equal? (md5 (read-file result-file-name)) - (md5 (read-file expected-file-name))) - (begin (display "passed\n") (delete-file result-file-name)) - (printf "failed! expected results in ~a, plot produced results in ~a\n" - expected-file-name - result-file-name)))])) + (let* ([bm1 (read-bitmap result-file-name)] + [bm2 (read-bitmap expected-file-name)] + [w (send bm1 get-width)] + [h (send bm1 get-height)] + [s1 (make-bytes (* 4 w h))] + [s2 (make-bytes (* 4 w h))]) + (send bm1 get-argb-pixels 0 0 w h s1) + (send bm2 get-argb-pixels 0 0 w h s2) + (if (and (= (send bm2 get-width) w) + (= (send bm2 get-width) h) + ;; The generated and target images can be a little different, + ;; but not much --- less than 1/255 difference average difference + ;; over all RGB components (which is really pretty close) + ((/ (for/fold ([diff 0]) ([i (in-range (* w h 4))]) + (+ diff (abs (- (bytes-ref s1 i) (bytes-ref s2 i))))) + (* w h 4)) + . <= . + 1.0)) + (begin (display "passed\n") (delete-file result-file-name)) + (begin + (printf "failed! expected results in ~a, plot produced results in ~a\n" + expected-file-name + result-file-name)))))])) (run-test "Line" (plot (line (lambda (x) x) #:color 'red)) diff --git a/collects/tests/plot/shade.png b/collects/tests/plot/shade.png index a7de045e16..1079df9222 100644 Binary files a/collects/tests/plot/shade.png and b/collects/tests/plot/shade.png differ diff --git a/collects/tests/plot/size.png b/collects/tests/plot/size.png index 4ec640c8f7..b3fa5023bb 100644 Binary files a/collects/tests/plot/size.png and b/collects/tests/plot/size.png differ diff --git a/collects/tests/plot/vector-field.png b/collects/tests/plot/vector-field.png index 5be95e1364..024de606e9 100644 Binary files a/collects/tests/plot/vector-field.png and b/collects/tests/plot/vector-field.png differ