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

more drawing repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-06-11 16:00:26 -06:00
parent dc00e22b85
commit 930fefc3fc
2 changed files with 38 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -342,11 +342,11 @@
(when (open?) (close)) (when (open?) (close))
(let ([dx (min (/ w 2) (let ([dx (min (/ w 2)
(if (negative? radius) (if (negative? radius)
(* w (- radius)) (* (min w h) (- radius))
radius))] radius))]
[dy (min (/ h 2) [dy (min (/ h 2)
(if (negative? radius) (if (negative? radius)
(* h (- radius)) (* (min w h) (- radius))
radius))]) radius))])
(move-to (+ x (- w dx)) y) (move-to (+ x (- w dx)) y)
(arc (+ x (- w (* 2 dx))) y (* 2 dx) (* 2 dy) pi/2 0.0 #f) (arc (+ x (- w (* 2 dx))) y (* 2 dx) (* 2 dy) pi/2 0.0 #f)

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

@ -188,8 +188,8 @@
(set! x-align-delta 0.5) (set! x-align-delta 0.5)
(set! y-align-delta 0.5)) (set! y-align-delta 0.5))
(begin (begin
(set! x-align-delta (/ (bitwise-and 1 (inexact->exact (floor (* scale-x w)))) 2.0)) (set! x-align-delta (/ (bitwise-and 1 (max 1 (inexact->exact (floor (* scale-x w))))) 2.0))
(set! y-align-delta (/ (bitwise-and 1 (inexact->exact (floor (* scale-y w)))) 2.0)))))) (set! y-align-delta (/ (bitwise-and 1 (max 1 (inexact->exact (floor (* scale-y w))))) 2.0))))))
(def/public (set-font [font% f]) (def/public (set-font [font% f])
(set! font f)) (set! font f))
@ -431,24 +431,33 @@
(install-color cr (install-color cr
(if (eq? s 'hilite) hilite-color col) (if (eq? s 'hilite) hilite-color col)
(if (eq? s 'hilite) hilite-alpha alpha)))) (if (eq? s 'hilite) hilite-alpha alpha))))
(cairo_set_line_width cr (let ([v (send pen get-width)]) (cairo_set_line_width cr (let* ([v (send pen get-width)]
[v (if (aligned? smoothing)
(/ (floor (* scale-x v)) scale-x)
v)])
(if (zero? v) (if (zero? v)
1 1
v))) v)))
(unless (or (eq? s 'solid) (unless (or (eq? s 'solid)
(eq? s 'xor)) (eq? s 'xor))
(cairo_set_dash cr (cairo_set_dash cr
(cond (let ([vec (cond
[(eq? s 'long-dash) [(eq? s 'long-dash)
#(4.0 2.0)] #(4.0 2.0)]
[(eq? s 'short-dash) [(eq? s 'short-dash)
#(2.0 2.0)] #(2.0 2.0)]
[(eq? s 'dot) [(eq? s 'dot)
#(1.0 1.0)] #(1.0 2.0)]
[(eq? s 'dot-dash) [(eq? s 'dot-dash)
#(1.0 2.0 4.0 2.0)] #(1.0 2.0 4.0 2.0)]
[else [else
#()]) #()])])
(let ([w (send pen get-width)])
(if (w . > . 1.0)
(list->vector
(for/list ([a (in-vector vec)])
(* a w)))
vec)))
(cond (cond
[(eq? s 'long-dash) 2] [(eq? s 'long-dash) 2]
[(eq? s 'short-dash) 2] [(eq? s 'short-dash) 2]
@ -592,23 +601,19 @@
cr cr
;; have to do pen separate from brush for ;; have to do pen separate from brush for
;; both alignment and height/width adjustment ;; both alignment and height/width adjustment
(let ([ax (align-x x)] (let ([rounded-rect
[ay (align-y y)]) (lambda (x y w h align-x align-y)
(let ([rounded-rect (let ([p (new dc-path%)])
(lambda (x y w h align-x align-y) (send p rounded-rectangle x y w h radius)
(let ([p (new dc-path%)]) (cairo_new_path cr)
(send p rounded-rectangle x y w h radius) (send p do-path cr align-x align-y)))])
(cairo_new_path cr) (when (brush-draws?)
(send p do-path cr align-x align-y)))]) (rounded-rect x y width height (lambda (x) x) (lambda (y) y))
(when (brush-draws?) (draw cr #t #f))
(rounded-rect x y width height (lambda (x) x) (lambda (y) y)) (when (pen-draws?)
(draw cr #t #f)) (rounded-rect x y (sub1 width) (sub1 height)
(when (pen-draws?) (lambda (x) (align-x x)) (lambda (y) (align-y y)))
(rounded-rect ax ay (draw cr #f #t)))))
(- (align-x (+ x (sub1 width))) ax)
(- (align-y (+ y (sub1 height))) ay)
(lambda (x) (align-x x)) (lambda (y) (align-y y)))
(draw cr #f #t))))))
(def/public (draw-spline [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3]) (def/public (draw-spline [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
(with-cr (with-cr