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

fixed a bug in text's color argument, as noted in PR 10998

Browse Source
This commit is contained in:
Robby Findler 2010-07-07 13:42:40 -05:00
parent c42d5c25c7
commit 070a39d902
2 changed files with 11 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/2htdp/tests/test-image.rkt
View File

@ -873,6 +873,10 @@
(image-height t) (image-height t)
'solid 'black)))))) 'solid 'black))))))
(test (text "ab" 18 (make-color 0 0 255))
=>
(text "ab" 18 "blue"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; triangle ;; triangle

10
collects/mrlib/image-core.rkt
View File

@ -725,9 +725,13 @@ has been moved out).
(let ([θ (degrees->radians (text-angle np-atomic-shape))] (let ([θ (degrees->radians (text-angle np-atomic-shape))]
[font (send dc get-font)]) [font (send dc get-font)])
(send dc set-font (text->font np-atomic-shape)) (send dc set-font (text->font np-atomic-shape))
(send dc set-text-foreground (let ([color (get-color-arg (text-color np-atomic-shape))])
(or (send the-color-database find-color (text-color np-atomic-shape)) (send dc set-text-foreground
(send the-color-database find-color "black"))) (cond
[(string? color)
(or (send the-color-database find-color color)
(send the-color-database find-color "black"))]
[else color])))
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))]) (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
(let ([p (- (make-rectangular dx dy) (let ([p (- (make-rectangular dx dy)
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])