105 lines
4.4 KiB
Racket
105 lines
4.4 KiB
Racket
(module bitmap-label mzscheme
|
|
(require mred
|
|
mzlib/class
|
|
mzlib/etc
|
|
mzlib/contract)
|
|
|
|
(provide/contract
|
|
[make-bitmap-label (opt->
|
|
(string?
|
|
(or/c path-string?
|
|
(is-a?/c bitmap%)))
|
|
((is-a?/c font%))
|
|
(is-a?/c bitmap%))]
|
|
[bitmap-label-maker (string?
|
|
(or/c path-string?
|
|
(is-a?/c bitmap%))
|
|
. -> .
|
|
(any/c . -> . (is-a?/c bitmap%)))])
|
|
|
|
(define make-bitmap-label
|
|
(opt-lambda (text filename-or-bitmap [font normal-control-font])
|
|
(let*-values ([(outside-margin) 2]
|
|
[(img-bitmap-dc img-bitmap img-width img-height)
|
|
(let ([mdc (make-object bitmap-dc%)]
|
|
[q (if (filename-or-bitmap . is-a? . bitmap%)
|
|
filename-or-bitmap
|
|
(make-object bitmap% filename-or-bitmap 'unknown/mask))])
|
|
(if (send q ok?)
|
|
(begin (send mdc set-bitmap q)
|
|
(values mdc
|
|
q
|
|
(send q get-width)
|
|
(send q get-height)))
|
|
(let ([b (make-object bitmap% 1 1)])
|
|
(send mdc set-bitmap b)
|
|
(send mdc clear)
|
|
(values mdc q 0 0))))]
|
|
[(width height descent leading)
|
|
(send img-bitmap-dc get-text-extent text font)]
|
|
[(middle-margin) (if (and (zero? img-width)
|
|
(zero? img-height))
|
|
0
|
|
3)]
|
|
[(new-width) (inexact->exact
|
|
(floor
|
|
(+ outside-margin
|
|
img-width
|
|
middle-margin
|
|
width
|
|
outside-margin)))]
|
|
[(new-height) (inexact->exact
|
|
(floor (+ outside-margin
|
|
(max img-height height)
|
|
outside-margin)))]
|
|
[(bitmap-dc) (make-object bitmap-dc%)]
|
|
[(new-bitmap) (make-object bitmap% new-width new-height)]
|
|
[(new-bitmap-mask) (make-object bitmap% new-width new-height)])
|
|
(send new-bitmap set-loaded-mask new-bitmap-mask)
|
|
(send img-bitmap-dc set-bitmap #f)
|
|
(send bitmap-dc set-bitmap new-bitmap-mask)
|
|
|
|
(send bitmap-dc set-font font)
|
|
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
|
|
|
|
|
(send bitmap-dc clear)
|
|
(send bitmap-dc draw-text text
|
|
(+ outside-margin img-width middle-margin)
|
|
(- (/ new-height 2) (/ height 2)))
|
|
|
|
(cond
|
|
[(send img-bitmap get-loaded-mask)
|
|
(send bitmap-dc draw-bitmap
|
|
(send img-bitmap get-loaded-mask)
|
|
outside-margin
|
|
(- (/ new-height 2) (/ img-height 2)))]
|
|
[else
|
|
(send bitmap-dc draw-rectangle
|
|
outside-margin
|
|
(- (/ new-height 2) (/ img-height 2))
|
|
img-width
|
|
img-height)])
|
|
|
|
(send bitmap-dc set-bitmap new-bitmap)
|
|
(send bitmap-dc clear)
|
|
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
|
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
|
;; Black rectangle to be masked by text:
|
|
(send bitmap-dc draw-rectangle
|
|
(sub1 (+ outside-margin img-width middle-margin))
|
|
0
|
|
(add1 width) new-height)
|
|
(send bitmap-dc draw-bitmap
|
|
img-bitmap
|
|
outside-margin
|
|
(- (/ new-height 2) (/ img-height 2)))
|
|
(send bitmap-dc set-bitmap #f)
|
|
new-bitmap)))
|
|
|
|
(define (bitmap-label-maker text filename-or-bitmap)
|
|
(let ([bm (make-bitmap-label text filename-or-bitmap)])
|
|
(lambda (area-container-window)
|
|
bm))))
|