racket/draw: add text-outline' to dc-path%'
This commit is contained in:
Matthew Flatt
parent
9bef0204bb
commit
6c5c170565
|
|
@ -7,12 +7,14 @@
|
|||
"fmod.rkt"
|
||||
"point.rkt"
|
||||
"transform.rkt"
|
||||
"font.rkt"
|
||||
(only-in scheme/base
|
||||
[append s:append]
|
||||
[reverse s:reverse]))
|
||||
|
||||
(provide dc-path%
|
||||
do-path)
|
||||
(protect-out do-path
|
||||
set-text-to-path!))
|
||||
|
||||
(define-local-member-name
|
||||
get-closed-points
|
||||
|
|
@ -22,6 +24,9 @@
|
|||
(define 2pi (* 2.0 pi))
|
||||
(define pi/2 (/ pi 2.0))
|
||||
|
||||
(define text-to-path #f)
|
||||
(define (set-text-to-path! proc) (set! text-to-path proc))
|
||||
|
||||
(define dc-path%
|
||||
(class object%
|
||||
;; A path is a list of pairs and vectors:
|
||||
|
|
@ -277,6 +282,19 @@
|
|||
(do-arc x y w h 0 2pi #f)
|
||||
(close))
|
||||
|
||||
(def/public (text-outline [font% font] [string? str] [real? x] [real? y] [any? [combine? #f]])
|
||||
(when (open?) (close))
|
||||
(let ([p (text-to-path font str x y combine?)])
|
||||
(for ([a (in-list p)])
|
||||
(case (car a)
|
||||
[(move) (move-to (cadr a) (caddr a))]
|
||||
[(line) (line-to (cadr a) (caddr a))]
|
||||
[(curve) (curve-to (cadr a) (caddr a)
|
||||
(list-ref a 2) (list-ref a 3)
|
||||
(list-ref a 4) (list-ref a 5))]
|
||||
[(close) (close)])))
|
||||
(close))
|
||||
|
||||
(def/public (scale [real? x][real? y])
|
||||
(unless (and (= x 1.0) (= y 1.0))
|
||||
(flatten-open!)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,8 @@
|
|||
|
||||
(define-local-member-name
|
||||
do-set-pen!
|
||||
do-set-brush!)
|
||||
do-set-brush!
|
||||
text-path)
|
||||
|
||||
(define 2pi (* 2 pi))
|
||||
|
||||
|
|
@ -1161,9 +1162,16 @@
|
|||
(with-cr
|
||||
(check-ok 'draw-text)
|
||||
cr
|
||||
(do-text cr #t s x y font combine? offset angle)
|
||||
(do-text cr 'draw s x y font combine? offset angle)
|
||||
(flush-cr)))
|
||||
|
||||
(define/public (text-path s x y combine?)
|
||||
(with-cr
|
||||
(check-ok 'draw-text)
|
||||
cr
|
||||
(do-text cr 'path s x y font combine? 0 0.0)
|
||||
(cairo_copy_path cr)))
|
||||
|
||||
(define size-cache (make-weak-hasheq))
|
||||
|
||||
(define/private (get-size-cache desc)
|
||||
|
|
@ -1231,12 +1239,12 @@
|
|||
(set-font-antialias c (dc-adjust-smoothing (send font get-smoothing)))
|
||||
c)))
|
||||
|
||||
(define/private (do-text cr draw? s x y font combine? offset angle)
|
||||
(define/private (do-text cr draw-mode s x y font combine? offset angle)
|
||||
(let* ([s (if (zero? offset)
|
||||
s
|
||||
(substring s offset))]
|
||||
[blank? (string=? s "")]
|
||||
[s (if (and (not draw?) blank?) " " s)]
|
||||
[s (if (and (not draw-mode) blank?) " " s)]
|
||||
[s (if (for/or ([c (in-string s)])
|
||||
(or (eqv? c #\uFFFE) (eqv? c #\uFFFF)))
|
||||
;; Since \uFFFE and \uFFFF are not supposed to be in any
|
||||
|
|
@ -1244,10 +1252,10 @@
|
|||
;; string to Pango:
|
||||
(regexp-replace* #rx"[\uFFFE\uFFFF]" s "\uFFFD")
|
||||
s)]
|
||||
[rotate? (and draw? (not (zero? angle)))]
|
||||
[rotate? (and draw-mode (not (zero? angle)))]
|
||||
[smoothing-index (get-smoothing-index)]
|
||||
[context (get-context cr smoothing-index)])
|
||||
(when draw?
|
||||
(when draw-mode
|
||||
(when (eq? text-mode 'solid)
|
||||
(unless rotate?
|
||||
(let-values ([(w h d a) (do-text cr #f s 0 0 font combine? 0 0.0)])
|
||||
|
|
@ -1276,7 +1284,7 @@
|
|||
;; This is combine mode. It has to be a little complicated, after all,
|
||||
;; because we may need to implement font substitution ourselves, which
|
||||
;; breaks the string into multiple layouts.
|
||||
(let loop ([s s] [draw? draw?] [measured? #f] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
|
||||
(let loop ([s s] [draw-mode draw-mode] [measured? #f] [w 0.0] [h 0.0] [d 0.0] [a 0.0])
|
||||
(cond
|
||||
[(not s)
|
||||
(when rotate? (cairo_restore cr))
|
||||
|
|
@ -1313,11 +1321,11 @@
|
|||
(install-alternate-face (string-ref s 0) layout font desc attrs context))
|
||||
(substring s (max 1 ok-count))))])
|
||||
(cond
|
||||
[(and draw? next-s (not measured?))
|
||||
[(and draw-mode next-s (not measured?))
|
||||
;; It's going to take multiple layouts, so first gather measurements.
|
||||
(let-values ([(w2 h d a) (loop s #f #f w h d a)])
|
||||
;; draw again, supplying `h', `d', and `a' for the whole line
|
||||
(loop s #t #t w h d a))]
|
||||
(loop s draw-mode #t w h d a))]
|
||||
[else
|
||||
(let ([logical (make-PangoRectangle 0 0 0 0)])
|
||||
(pango_layout_get_extents layout #f logical)
|
||||
|
|
@ -1325,16 +1333,19 @@
|
|||
[nd (/ (- (PangoRectangle-height logical)
|
||||
(pango_layout_get_baseline layout))
|
||||
(exact->inexact PANGO_SCALE))])
|
||||
(when draw?
|
||||
(when draw-mode
|
||||
(let ([bl (if measured? (- h d) (- nh nd))])
|
||||
(pango_layout_get_extents layout #f logical)
|
||||
(cairo_move_to cr
|
||||
(text-align-x/delta (+ x w) 0)
|
||||
(text-align-y/delta (+ y bl) 0))
|
||||
;; Draw the text:
|
||||
(pango_cairo_show_layout_line cr (pango_layout_get_line_readonly layout 0))))
|
||||
(let ([line (pango_layout_get_line_readonly layout 0)])
|
||||
(if (eq? draw-mode 'draw)
|
||||
(pango_cairo_show_layout_line cr line)
|
||||
(pango_cairo_layout_line_path cr line)))))
|
||||
(cond
|
||||
[(and draw? (not next-s))
|
||||
[(and draw-mode (not next-s))
|
||||
(g_object_unref layout)
|
||||
(when rotate? (cairo_restore cr))]
|
||||
[else
|
||||
|
|
@ -1342,7 +1353,7 @@
|
|||
0.0
|
||||
(integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE))))]
|
||||
[na 0.0])
|
||||
(loop next-s measured? draw? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))]))
|
||||
(loop next-s draw-mode measured? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))]))
|
||||
;; This is character-by-character mode. It uses a cached per-character+font layout
|
||||
;; object.
|
||||
(let ([cache (if (or combine?
|
||||
|
|
@ -1397,7 +1408,7 @@
|
|||
;; character or if we're just measuring text.
|
||||
(begin0
|
||||
(unless (and
|
||||
draw?
|
||||
(eq? draw-mode 'draw)
|
||||
cache
|
||||
(not attrs) ; fast path doesn't handle underline
|
||||
((string-length s) . > . 1)
|
||||
|
|
@ -1489,13 +1500,16 @@
|
|||
;; unrounded height, for slow-path alignment
|
||||
flh)))
|
||||
(values lw lh ld la flh)))))))])
|
||||
(when draw?
|
||||
(when draw-mode
|
||||
(cairo_move_to cr
|
||||
(text-align-x/delta (+ x w) 0)
|
||||
(let ([bl (- flh ld)])
|
||||
(text-align-y/delta (+ y bl) 0)))
|
||||
;; Here's the draw command, which uses most of the time in this mode:
|
||||
(pango_cairo_show_layout_line cr (pango_layout_get_line_readonly layout 0)))
|
||||
(let ([line (pango_layout_get_line_readonly layout 0)])
|
||||
(if (eq? draw-mode 'draw)
|
||||
(pango_cairo_show_layout_line cr line)
|
||||
(pango_cairo_layout_line_path cr line))))
|
||||
(values (if blank? 0.0 (+ w lw)) (max h lh) (max d ld) (max a la))))))
|
||||
(when rotate? (cairo_restore cr))))))))
|
||||
|
||||
|
|
@ -1518,7 +1532,7 @@
|
|||
(vector-set! vec 2 #f)
|
||||
(vector-set! vec 3 #f)
|
||||
(vector-set! vec 4 #f)))))
|
||||
|
||||
|
||||
(def/public (start-doc [string? desc])
|
||||
(check-ok 'start-doc))
|
||||
(def/public (end-doc)
|
||||
|
|
@ -1819,3 +1833,14 @@
|
|||
(void))
|
||||
|
||||
dc%)
|
||||
|
||||
(set-text-to-path!
|
||||
(lambda (font str x y combine?)
|
||||
(define tmp-bm (make-object bitmap% 10 10))
|
||||
(define tmp-dc (make-object -bitmap-dc% tmp-bm))
|
||||
(send tmp-dc set-font font)
|
||||
(define path (send tmp-dc text-path str x y combine?))
|
||||
(begin0
|
||||
(cairo-path->list path)
|
||||
(cairo_path_destroy path))))
|
||||
|
||||
|
|
|
|||
|
|
@ -428,3 +428,59 @@
|
|||
CAIRO_FILTER_GAUSSIAN)
|
||||
|
||||
(define/provide CAIRO_CONTENT_COLOR_ALPHA #x3000)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-cstruct _cairo_path_data_t_header ([type _int]
|
||||
[length _int]))
|
||||
(define-cstruct _cairo_path_data_t_point ([x _double]
|
||||
[y _double]))
|
||||
|
||||
(define _cairo_path_data_t (_union
|
||||
_cairo_path_data_t_header
|
||||
_cairo_path_data_t_point))
|
||||
|
||||
(define-cstruct _cairo_path_t ([status _int]
|
||||
[data _pointer]
|
||||
[num_data _int]))
|
||||
|
||||
(define-cairo cairo_path_destroy (_fun _cairo_path_t-pointer -> _void)
|
||||
#:wrap (deallocator))
|
||||
|
||||
(define-cairo cairo_copy_path (_fun _cairo_t -> _cairo_path_t-pointer)
|
||||
#:wrap (allocator cairo_path_destroy))
|
||||
|
||||
(define-enum 0
|
||||
CAIRO_PATH_MOVE_TO
|
||||
CAIRO_PATH_LINE_TO
|
||||
CAIRO_PATH_CURVE_TO
|
||||
CAIRO_PATH_CLOSE_PATH)
|
||||
|
||||
(provide cairo-path->list)
|
||||
|
||||
(define (cairo-path->list path)
|
||||
(define len (cairo_path_t-num_data path))
|
||||
(define data (cairo_path_t-data path))
|
||||
(let loop ([i 0])
|
||||
(if (= i len)
|
||||
null
|
||||
(let ([h (union-ref (ptr-ref data _cairo_path_data_t i) 0)])
|
||||
(cons (let ([t (cairo_path_data_t_header-type h)])
|
||||
(cond
|
||||
[(or (= t CAIRO_PATH_MOVE_TO)
|
||||
(= t CAIRO_PATH_LINE_TO))
|
||||
(define a (union-ref (ptr-ref data _cairo_path_data_t (add1 i)) 1))
|
||||
(list (if (= t CAIRO_PATH_MOVE_TO) 'move 'line)
|
||||
(cairo_path_data_t_point-x a)
|
||||
(cairo_path_data_t_point-y a))]
|
||||
[(= t CAIRO_PATH_CURVE_TO)
|
||||
(define a (union-ref (ptr-ref data _cairo_path_data_t (+ 1 i)) 1))
|
||||
(define b (union-ref (ptr-ref data _cairo_path_data_t (+ 2 i)) 1))
|
||||
(define c (union-ref (ptr-ref data _cairo_path_data_t (+ 3 i)) 1))
|
||||
(list 'curve
|
||||
(cairo_path_data_t_point-x a) (cairo_path_data_t_point-y a)
|
||||
(cairo_path_data_t_point-x b) (cairo_path_data_t_point-y b)
|
||||
(cairo_path_data_t_point-x c) (cairo_path_data_t_point-y c))]
|
||||
[(= t CAIRO_PATH_CLOSE_PATH)
|
||||
'(close)]))
|
||||
(loop (+ i (cairo_path_data_t_header-length h))))))))
|
||||
|
|
|
|||
|
|
@ -185,6 +185,7 @@
|
|||
(define-pangocairo pango_cairo_show_layout (_pfun _cairo_t PangoLayout -> _void))
|
||||
(define-pangocairo pango_cairo_show_layout_line (_pfun _cairo_t PangoLayoutLine -> _void))
|
||||
(define-pangocairo pango_cairo_show_glyph_string (_pfun _cairo_t PangoFont _PangoGlyphString-pointer -> _void))
|
||||
(define-pangocairo pango_cairo_layout_line_path (_pfun _cairo_t PangoLayoutLine -> _void))
|
||||
|
||||
(define-pango pango_layout_iter_free (_pfun PangoLayoutIter -> _void)
|
||||
#:wrap (deallocator))
|
||||
|
|
|
|||
|
|
@ -264,6 +264,21 @@ If @racket[radius] is less than @racket[-0.5] or more than half of
|
|||
|
||||
}
|
||||
|
||||
@defmethod[(text-outline [font (is-a?/c font%)]
|
||||
[str string?]
|
||||
[x real?]
|
||||
[y real?]
|
||||
[combine? any/c #f])
|
||||
void?]{
|
||||
|
||||
Closes the @tech{open sub-path}, if any, and adds a @tech{closed
|
||||
sub-path} to outline @racket[str] using @racket[font]. The
|
||||
top left of the text is positioned at @racket[x] and @racket[y]. The
|
||||
@racket[combine?] argument enables kerning and character combinations
|
||||
as for @xmethod[dc<%> draw-text].
|
||||
|
||||
}
|
||||
|
||||
@defmethod[(translate [x real?]
|
||||
[y real?])
|
||||
void?]{
|
||||
|
|
|
|||
|
|
@ -659,6 +659,17 @@
|
|||
(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h) #f)))))
|
||||
(send dc set-pen save-pen)))
|
||||
|
||||
;; Text paths:
|
||||
(let ([p (make-object dc-path%)]
|
||||
[old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
(send p text-outline (make-font #:size 32) "A" 360 190)
|
||||
(send dc set-pen "black" 1 'solid)
|
||||
(send dc set-brush "pink" 'solid)
|
||||
(send dc draw-path p)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush))
|
||||
|
||||
; Bitmap copying:
|
||||
(when (and (not no-bitmaps?) last?)
|
||||
(let ([x 5] [y 165])
|
||||
|
|
@ -1080,6 +1091,11 @@
|
|||
[(lam) (let ([r (make-object region% clip-dc)])
|
||||
(send r set-path lambda-path)
|
||||
(send dc set-clipping-region r))]
|
||||
[(A) (let ([p (new dc-path%)]
|
||||
[r (make-object region% clip-dc)])
|
||||
(send p text-outline (make-font #:size 256) "A" 10 10)
|
||||
(send r set-path p)
|
||||
(send dc set-clipping-region r))]
|
||||
[(rect+poly) (let ([r (mk-poly 'winding)])
|
||||
(send r union (mk-rect))
|
||||
(send dc set-clipping-region r))]
|
||||
|
|
@ -1161,7 +1177,8 @@
|
|||
(let*-values ([(x y w h) (send r get-bounding-box)]
|
||||
[(l) (list x y w h)]
|
||||
[(=~) (lambda (x y)
|
||||
(<= (- x 2) y (+ x 2)))])
|
||||
(or (not y)
|
||||
(<= (- x 2) y (+ x 2))))])
|
||||
(unless (andmap =~ l
|
||||
(let ([l
|
||||
(case clip
|
||||
|
|
@ -1170,6 +1187,7 @@
|
|||
[(poly circle poly-rect) '(0. 60. 180. 180.)]
|
||||
[(wedge) '(26. 60. 128. 90.)]
|
||||
[(lam) '(58. 10. 202. 281.)]
|
||||
[(A) '(#f #f #f #f)]
|
||||
[(rect+poly rect+circle poly^rect) '(0. -25. 180. 400.)]
|
||||
[(poly&rect) '(100. 60. 10. 180.)]
|
||||
[(roundrect) '(80. 200. 125. 40.)]
|
||||
|
|
@ -1293,14 +1311,14 @@
|
|||
(send canvas set-kern (send self get-value))))
|
||||
(make-object choice% "Clip"
|
||||
'("None" "Rectangle" "Rectangle2" "Octagon"
|
||||
"Circle" "Wedge" "Round Rectangle" "Lambda"
|
||||
"Circle" "Wedge" "Round Rectangle" "Lambda" "A"
|
||||
"Rectangle + Octagon" "Rectangle + Circle"
|
||||
"Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka"
|
||||
"Empty")
|
||||
hp3
|
||||
(lambda (self event)
|
||||
(set! clip (list-ref
|
||||
'(none rect rect2 poly circle wedge roundrect lam
|
||||
'(none rect rect2 poly circle wedge roundrect lam A
|
||||
rect+poly rect+circle poly-rect poly&rect poly^rect
|
||||
polka empty)
|
||||
(send self get-selection)))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
Version 5.2.0.7
|
||||
Intern strings, etc., only in read-syntax mode, not read mode
|
||||
racket/draw: add text-outline to dc-path%
|
||||
|
||||
Version 5.2.0.6
|
||||
Added pseudo-random-generator-vector?
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user