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

fixed some bad behavior (that I never completely understood) by changing the interpretation of the base images as drawing their centers at (0,0) instead of drawing their upper left corners at (0,0)

Browse Source 
svn: r16676

original commit: 4e3b1b4c2651dab785fc6e20db1d6c36af629d5c
This commit is contained in:
Robby Findler 2009-11-10 23:36:32 +00:00
parent 25ea3f5776
commit 206817ea52
1 changed files with 22 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/mrlib/image-core.ss
View File

@ -349,6 +349,11 @@ has been moved out).
[else [else
(error 'normalize-shape "unknown shape ~s\n" shape)]))) (error 'normalize-shape "unknown shape ~s\n" shape)])))
(define (simple-shape? shape)
(or (and (translate? shape)
(np-atomic-shape? (translate-shape shape)))
(polygon? shape)))
(define (atomic-shape? shape) (define (atomic-shape? shape)
(or (polygon? shape) (or (polygon? shape)
(np-atomic-shape? shape))) (np-atomic-shape? shape)))
@ -460,17 +465,18 @@ has been moved out).
(send path ellipse 0 0 ew eh) (send path ellipse 0 0 ew eh)
(send path translate (- (/ ew 2)) (- (/ eh 2))) (send path translate (- (/ ew 2)) (- (/ eh 2)))
(send path rotate θ) (send path rotate θ)
(send path translate (/ rotated-width 2) (/ rotated-height 2))
(send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape))) (send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
(send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape))) (send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
(send dc draw-path path dx dy)))] (send dc draw-path path dx dy)))]
[(bitmap? atomic-shape) [(bitmap? atomic-shape)
(send dc draw-bitmap (let ([bm (bitmap-raw-bitmap atomic-shape)])
(bitmap-raw-bitmap atomic-shape) (send dc draw-bitmap
dx dy bm
'solid (- dx (/ (send bm get-width) 2))
(send the-color-database find-color "black") (- dy (/ (send bm get-height) 2))
(bitmap-raw-mask atomic-shape))] 'solid
(send the-color-database find-color "black")
(bitmap-raw-mask atomic-shape)))]
[(text? atomic-shape) [(text? atomic-shape)
(let ([θ (degrees->radians (text-angle atomic-shape))] (let ([θ (degrees->radians (text-angle atomic-shape))]
[font (send dc get-font)]) [font (send dc get-font)])
@ -478,7 +484,13 @@ has been moved out).
(send dc set-text-foreground (send dc set-text-foreground
(or (send the-color-database find-color (text-color atomic-shape)) (or (send the-color-database find-color (text-color atomic-shape))
(send the-color-database find-color "black"))) (send the-color-database find-color "black")))
(send dc draw-text (text-string atomic-shape) dx dy #f 0 θ))]))])) (let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
(let ([p (- (make-rectangular dx dy)
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
(send dc draw-text (text-string atomic-shape)
(real-part p)
(imag-part p)
#f 0 θ))))]))]))
(define (text->font text) (define (text->font text)
(cond (cond
@ -562,3 +574,5 @@ has been moved out).
;; method names ;; method names
(provide get-shape get-bb get-normalized?) (provide get-shape get-bb get-normalized?)
(provide np-atomic-shape? atomic-shape? simple-shape?)