suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

drawing repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-06-04 16:17:25 -06:00
parent cee45914f4
commit 88606ae251
3 changed files with 50 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/racket/draw/dc-path.rkt
View File

@ -95,7 +95,7 @@
(vector (vector-ref p 2) (vector-ref p 3) (vector (vector-ref p 2) (vector-ref p 3)
(vector-ref p 0) (vector-ref p 1)))) (vector-ref p 0) (vector-ref p 1))))
l))]) 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))))) (set! closed-points (map rev-one (map s:reverse closed-points)))))
(def/public (close) (def/public (close)
@ -140,7 +140,7 @@
(def/public (move-to [real? x] [real? y]) (def/public (move-to [real? x] [real? y])
(when (or (pair? open-points) (when (or (pair? open-points)
(pair? rev-open-points)) (pair? rev-open-points))
(error (method-name 'dc-path% 'move-to) "path already open")) (close))
(do-move-to x y)) (do-move-to x y))
(define/private (do-move-to x y) (define/private (do-move-to x y)
@ -161,10 +161,10 @@
(unless (or (pair? open-points) (unless (or (pair? open-points)
(pair? rev-open-points)) (pair? rev-open-points))
(error (method-name 'dc-path% 'lines) "path not yet open")) (error (method-name 'dc-path% 'lines) "path not yet open"))
(for ([p (in-lines pts)]) (for ([p (in-list pts)])
(if (pair? p) (if (pair? p)
(do-line-to (car p) (cdr p)) (do-line-to (+ x (car p)) (+ y (cdr p)))
(do-line-to (point-x p) (point-y 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]) (def/public (curve-to [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
(unless (or (pair? open-points) (unless (or (pair? open-points)

59
collects/racket/draw/dc.rkt
View File

@ -238,18 +238,25 @@
(define smoothing 'unsmoothed) (define smoothing 'unsmoothed)
(define/private (aligned? s)
(not (eq? s 'smoothed)))
(def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s]) (def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s])
(set! smoothing s)) (set! smoothing s))
(def/public (get-smoothing) (def/public (get-smoothing)
smoothing) smoothing)
(define/private (align-x x) (define/private (align-x/delta x delta)
(if (eq? smoothing 'aligned) (if (aligned? smoothing)
(/ (- (+ (floor (+ (* x scale-x) origin-x)) x-align-delta) origin-x) scale-x) (/ (- (+ (floor (+ (* x scale-x) origin-x)) delta) origin-x) scale-x)
x)) x))
(define/private (align-y y) (define/private (align-x x)
(if (eq? smoothing 'aligned) (align-x/delta x x-align-delta))
(/ (- (+ (floor (+ (* y scale-y) origin-y)) y-align-delta) origin-y) scale-y) (define/private (align-y/delta y delta)
(if (aligned? smoothing)
(/ (- (+ (floor (+ (* y scale-y) origin-y)) delta) origin-y) scale-y)
y)) y))
(define/private (align-y y)
(align-y/delta y y-align-delta))
(define (set-font-antialias context smoothing) (define (set-font-antialias context smoothing)
(let ([o (pango_cairo_context_get_font_options context)] (let ([o (pango_cairo_context_get_font_options context)]
@ -491,9 +498,13 @@
(cairo_save cr) (cairo_save cr)
(cairo_translate cr center-x center-y) (cairo_translate cr center-x center-y)
(cairo_scale cr radius-x radius-y) (cairo_scale cr radius-x radius-y)
(when brush?
(cairo_move_to cr 0 0))
(cairo_arc_negative cr 0 0 1 (cairo_arc_negative cr 0 0 1
(- start-radians) (- start-radians)
(- end-radians)) (- end-radians))
(when brush?
(cairo_close_path cr))
(cairo_restore cr) (cairo_restore cr)
(draw cr brush? pen?))))]) (draw cr brush? pen?))))])
(when (brush-draws?) (when (brush-draws?)
@ -515,7 +526,7 @@
cr cr
(cairo_new_path cr) (cairo_new_path cr)
(cairo_move_to cr (align-x x1) (align-y y1)) (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 ;; An unsmoothed line is supposed to hit the pixel to the
;; lower right of the ending point. (We've revered the points ;; lower right of the ending point. (We've revered the points
;; above to ensure that the line goes left to right.) ;; above to ensure that the line goes left to right.)
@ -643,7 +654,7 @@
CAIRO_FILL_RULE_EVEN_ODD)) CAIRO_FILL_RULE_EVEN_ODD))
(cairo_new_path cr) (cairo_new_path cr)
(cairo_translate cr dx dy) (cairo_translate cr dx dy)
(if (eq? smoothing 'aligned) (if (aligned? smoothing)
(begin (begin
(when (brush-draws?) (when (brush-draws?)
(send path do-path cr (lambda (x) x) (lambda (y) y)) (send path do-path cr (lambda (x) x) (lambda (y) y))
@ -801,15 +812,21 @@
(with-cr (with-cr
(void) (void)
cr cr
(let ([stamp-pattern (let* ([color (or color black)]
(lambda (src) [a-dest-x (align-x/delta dest-x 0)]
(let ([p (cairo_pattern_create_for_surface (send src get-cairo-alpha-surface))] [a-dest-y (align-y/delta dest-y 0)]
[m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)]) [a-dest-w (- (align-x/delta (+ dest-x src-w) 0) a-dest-x)]
(cairo_matrix_init_translate m (- src-x dest-x) (- src-y dest-y)) [a-dest-h (- (align-y/delta (+ dest-y src-h) 0) a-dest-y)]
(cairo_pattern_set_matrix p m) [a-src-x (floor src-x)]
(cairo_mask cr p) [a-src-y (floor src-y)]
(cairo_pattern_destroy p)))] [stamp-pattern
[color (or color black)]) (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 (cond
[(or (send src is-color?) [(or (send src is-color?)
(and (not (eq? style 'opaque)) (and (not (eq? style 'opaque))
@ -818,13 +835,13 @@
(cairo_pattern_reference s) (cairo_pattern_reference s)
(cairo_set_source_surface cr (cairo_set_source_surface cr
(send src get-cairo-surface) (send src get-cairo-surface)
(- dest-x src-x) (- a-dest-x a-src-x)
(- dest-y src-y)) (- a-dest-y a-src-y))
(if mask (if mask
(stamp-pattern mask) (stamp-pattern mask)
(begin (begin
(cairo_new_path cr) (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_fill cr)))
(cairo_set_source cr s) (cairo_set_source cr s)
(cairo_pattern_destroy s))] (cairo_pattern_destroy s))]
@ -832,7 +849,7 @@
(when (eq? style 'opaque) (when (eq? style 'opaque)
(install-color cr bg alpha) (install-color cr bg alpha)
(cairo_new_path cr) (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_fill cr))
(install-color cr color alpha) (install-color cr color alpha)
(stamp-pattern src)]) (stamp-pattern src)])

9
collects/tests/gracket/draw.rkt
View File

@ -722,9 +722,11 @@
(let ([start x]) (let ([start x])
;; First three return icons: ;; First three return icons:
(do-one return 'solid black) (do-one return 'solid black)
(printf "HERE\n")
(do-one return 'solid red) (do-one return 'solid red)
(printf "DONE\n")
(do-one return 'opaque red) (do-one return 'opaque red)
;; Next three, on a bluew background ;; Next three, on a blue background
(let ([end x] (let ([end x]
[b (send dc get-brush)]) [b (send dc get-brush)])
(send dc set-brush (make-object brush% "BLUE" 'solid)) (send dc set-brush (make-object brush% "BLUE" 'solid))
@ -1088,7 +1090,10 @@
[use-bad? #t] [use-bad? #t]
[use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
[else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 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) (send dc set-clipping-region #f)