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

Reimplement shapes with borders to deal with transparency better.

Browse Source
This commit is contained in:
Vincent St-Amour 2014-03-26 16:48:32 -04:00
parent 6af65ee19a
commit 958b9fdc02
2 changed files with 57 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/unstable-pkgs/unstable-doc/scribblings/gui/pict.scrbl
View File

@ -296,8 +296,10 @@ Sets @racket[pict-combine] to refer to @racket[combine-id] within each of the
These functions create shapes with border of the given color and width. These functions create shapes with border of the given color and width.
@examples[#:eval the-eval @examples[#:eval the-eval
(ellipse/border 40 20 #:border-color "blue") (ellipse/border 80 40 #:border-color "blue")
(rounded-rectangle/border 40 20 #:color "red") (rounded-rectangle/border 60 60 #:color "red" #:angle 1 #:border-width 3)
(circle/border 40 #:color "green" #:border-color "purple")
(rectangle/border 200 20 #:border-width 5)
] ]
} }

90
pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt
View File

@ -209,46 +209,62 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following has been added by stamourv ;; the following has been added by stamourv, then replaced with implementations
;; adapted from Ian Johnson
;; borders may be of slightly uneven width, sadly (define (draw-shape/border dc-path color border-color border-width)
(define-values (ellipse/border (define-values (color* style)
rectangle/border) (if color
(let () (values color 'solid)
(define ((mk shape) w h (values "white" 'transparent)))
#:color (color "white") (let-values ([(x y w h) (send dc-path get-bounding-box)])
#:border-color (border-color "black") (dc (λ (dc dx dy)
#:border-width (border-width 2)) (define old-brush (send dc get-brush))
(cc-superimpose (define old-pen (send dc get-pen))
(colorize (shape w h) border-color) (send dc set-brush
(colorize (shape (- w (* 2 border-width)) (send the-brush-list find-or-create-brush color* style))
(- h (* 2 border-width))) (send dc set-pen (send the-pen-list
color))) find-or-create-pen
(values (mk filled-ellipse) border-color
(mk filled-rectangle)))) border-width
'solid))
(define (rounded-rectangle/border (send dc draw-path dc-path (- dx x) (- dy y))
w h (send dc set-brush old-brush)
#:color (color "white") (send dc set-pen old-pen))
#:border-color (border-color "black") w h)))
#:border-width (border-width 2)
#:corner-radius (radius -0.25)
#:angle (angle 0))
(cc-superimpose
(colorize (filled-rounded-rectangle w h radius #:angle angle) border-color)
(colorize (filled-rounded-rectangle
(- w (* 2 border-width))
(- h (* 2 border-width)) radius #:angle angle)
color)))
(define (ellipse/border ew eh
#:color [color #f]
#:border-color [border-color "black"]
#:border-width [border-width 2])
(define dc-path (new dc-path%))
(send dc-path ellipse 0 0 ew eh)
(draw-shape/border dc-path color border-color border-width))
(define (circle/border d (define (circle/border d
#:color (color "white") #:color [color #f]
#:border-color (border-color "black") #:border-color [border-color "black"]
#:border-width (border-width 2)) #:border-width [border-width 2])
(cc-superimpose (ellipse/border d d
(colorize (disk d) border-color) #:color color #:border-color border-color
(colorize (disk (- d (* 2 border-width))) #:border-width border-width))
color))) (define (rounded-rectangle/border w h
#:color [color #f]
#:border-color [border-color "black"]
#:border-width [border-width 2]
#:corner-radius [corner-radius -0.25]
#:angle [angle 0])
(define dc-path (new dc-path%))
(send dc-path rounded-rectangle 0 0 w h corner-radius)
(send dc-path rotate angle)
(draw-shape/border dc-path color border-color border-width))
(define (rectangle/border w h
#:color [color #f]
#:border-color [border-color "black"]
#:border-width [border-width 2]
#:corner-radius [corner-radius -0.25])
(define dc-path (new dc-path%))
(send dc-path rectangle 0 0 w h)
(draw-shape/border dc-path color border-color border-width))
(define shape/border-contract (define shape/border-contract
(->* [real? real?] (->* [real? real?]