diff --git a/collects/racket/draw/dc-path.rkt b/collects/racket/draw/dc-path.rkt index c5c69df11a..968adae226 100644 --- a/collects/racket/draw/dc-path.rkt +++ b/collects/racket/draw/dc-path.rkt @@ -95,7 +95,7 @@ (vector (vector-ref p 2) (vector-ref p 3) (vector-ref p 0) (vector-ref p 1)))) l))]) - (set! open-points (map rev-one (s:reverse open-points))) + (set! open-points (rev-one (s:reverse open-points))) (set! closed-points (map rev-one (map s:reverse closed-points))))) (def/public (close) @@ -140,7 +140,7 @@ (def/public (move-to [real? x] [real? y]) (when (or (pair? open-points) (pair? rev-open-points)) - (error (method-name 'dc-path% 'move-to) "path already open")) + (close)) (do-move-to x y)) (define/private (do-move-to x y) @@ -161,10 +161,10 @@ (unless (or (pair? open-points) (pair? rev-open-points)) (error (method-name 'dc-path% 'lines) "path not yet open")) - (for ([p (in-lines pts)]) + (for ([p (in-list pts)]) (if (pair? p) - (do-line-to (car p) (cdr p)) - (do-line-to (point-x p) (point-y p))))) + (do-line-to (+ x (car p)) (+ y (cdr p))) + (do-line-to (+ x (point-x p)) (+ y (point-y p)))))) (def/public (curve-to [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3]) (unless (or (pair? open-points) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 7bbfcebbf8..36e70d0332 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -238,18 +238,25 @@ (define smoothing 'unsmoothed) + (define/private (aligned? s) + (not (eq? s 'smoothed))) + (def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s]) (set! smoothing s)) (def/public (get-smoothing) smoothing) - (define/private (align-x x) - (if (eq? smoothing 'aligned) - (/ (- (+ (floor (+ (* x scale-x) origin-x)) x-align-delta) origin-x) scale-x) + (define/private (align-x/delta x delta) + (if (aligned? smoothing) + (/ (- (+ (floor (+ (* x scale-x) origin-x)) delta) origin-x) scale-x) x)) - (define/private (align-y y) - (if (eq? smoothing 'aligned) - (/ (- (+ (floor (+ (* y scale-y) origin-y)) y-align-delta) origin-y) scale-y) + (define/private (align-x x) + (align-x/delta x x-align-delta)) + (define/private (align-y/delta y delta) + (if (aligned? smoothing) + (/ (- (+ (floor (+ (* y scale-y) origin-y)) delta) origin-y) scale-y) y)) + (define/private (align-y y) + (align-y/delta y y-align-delta)) (define (set-font-antialias context smoothing) (let ([o (pango_cairo_context_get_font_options context)] @@ -491,9 +498,13 @@ (cairo_save cr) (cairo_translate cr center-x center-y) (cairo_scale cr radius-x radius-y) + (when brush? + (cairo_move_to cr 0 0)) (cairo_arc_negative cr 0 0 1 (- start-radians) (- end-radians)) + (when brush? + (cairo_close_path cr)) (cairo_restore cr) (draw cr brush? pen?))))]) (when (brush-draws?) @@ -515,7 +526,7 @@ cr (cairo_new_path cr) (cairo_move_to cr (align-x x1) (align-y y1)) - (if (eq? smoothing 'unsmoothed) + (if #f ; (eq? smoothing 'unsmoothed) ;; An unsmoothed line is supposed to hit the pixel to the ;; lower right of the ending point. (We've revered the points ;; above to ensure that the line goes left to right.) @@ -643,7 +654,7 @@ CAIRO_FILL_RULE_EVEN_ODD)) (cairo_new_path cr) (cairo_translate cr dx dy) - (if (eq? smoothing 'aligned) + (if (aligned? smoothing) (begin (when (brush-draws?) (send path do-path cr (lambda (x) x) (lambda (y) y)) @@ -801,15 +812,21 @@ (with-cr (void) cr - (let ([stamp-pattern - (lambda (src) - (let ([p (cairo_pattern_create_for_surface (send src get-cairo-alpha-surface))] - [m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)]) - (cairo_matrix_init_translate m (- src-x dest-x) (- src-y dest-y)) - (cairo_pattern_set_matrix p m) - (cairo_mask cr p) - (cairo_pattern_destroy p)))] - [color (or color black)]) + (let* ([color (or color black)] + [a-dest-x (align-x/delta dest-x 0)] + [a-dest-y (align-y/delta dest-y 0)] + [a-dest-w (- (align-x/delta (+ dest-x src-w) 0) a-dest-x)] + [a-dest-h (- (align-y/delta (+ dest-y src-h) 0) a-dest-y)] + [a-src-x (floor src-x)] + [a-src-y (floor src-y)] + [stamp-pattern + (lambda (src) + (let ([p (cairo_pattern_create_for_surface (send src get-cairo-alpha-surface))] + [m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)]) + (cairo_matrix_init_translate m (- a-src-x a-dest-x) (- a-src-y a-dest-y)) + (cairo_pattern_set_matrix p m) + (cairo_mask cr p) + (cairo_pattern_destroy p)))]) (cond [(or (send src is-color?) (and (not (eq? style 'opaque)) @@ -818,13 +835,13 @@ (cairo_pattern_reference s) (cairo_set_source_surface cr (send src get-cairo-surface) - (- dest-x src-x) - (- dest-y src-y)) + (- a-dest-x a-src-x) + (- a-dest-y a-src-y)) (if mask (stamp-pattern mask) (begin (cairo_new_path cr) - (cairo_rectangle cr dest-x dest-y src-w src-h) + (cairo_rectangle cr a-dest-x a-dest-y a-dest-w a-dest-h) (cairo_fill cr))) (cairo_set_source cr s) (cairo_pattern_destroy s))] @@ -832,7 +849,7 @@ (when (eq? style 'opaque) (install-color cr bg alpha) (cairo_new_path cr) - (cairo_rectangle cr dest-x dest-y src-w src-h) + (cairo_rectangle cr a-dest-x a-dest-y a-dest-w a-dest-h) (cairo_fill cr)) (install-color cr color alpha) (stamp-pattern src)]) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 0af3b7f9db..4d7f2b3566 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -722,9 +722,11 @@ (let ([start x]) ;; First three return icons: (do-one return 'solid black) + (printf "HERE\n") (do-one return 'solid red) + (printf "DONE\n") (do-one return 'opaque red) - ;; Next three, on a bluew background + ;; Next three, on a blue background (let ([end x] [b (send dc get-brush)]) (send dc set-brush (make-object brush% "BLUE" 'solid)) @@ -1088,7 +1090,10 @@ [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) - (error 'x "wrong size reported by get-size: ~a ~a" w h))) + (error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h + (if use-bitmap? + (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) + (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (send dc set-clipping-region #f)