75 lines
2.6 KiB
Racket
75 lines
2.6 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
racket/contract)
|
|
|
|
(provide/contract
|
|
[make-bitmap-label (->* (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 text filename-or-bitmap [font normal-control-font])
|
|
(define outside-margin 2)
|
|
(define-values (img-bitmap img-width img-height)
|
|
(let ([q (if (filename-or-bitmap . is-a? . bitmap%)
|
|
filename-or-bitmap
|
|
(make-object bitmap% filename-or-bitmap 'unknown/mask))])
|
|
(if (send q ok?)
|
|
(values q
|
|
(send q get-width)
|
|
(send q get-height))
|
|
(let* ([b (make-object bitmap% 1 1)]
|
|
[bdc (make-object bitmap-dc% b)])
|
|
(send bdc clear)
|
|
(send bdc set-bitmap #f)
|
|
(values b 0 0)))))
|
|
(define-values (width height _1 _2)
|
|
(let ([tmp-bitmap-dc (make-object bitmap-dc% (make-bitmap 1 1))])
|
|
(send tmp-bitmap-dc get-text-extent text font)))
|
|
(define middle-margin (if (and (zero? img-width)
|
|
(zero? img-height))
|
|
0
|
|
3))
|
|
(define new-width (inexact->exact
|
|
(floor
|
|
(+ outside-margin
|
|
img-width
|
|
middle-margin
|
|
width
|
|
outside-margin))))
|
|
(define new-height (inexact->exact
|
|
(floor (+ outside-margin
|
|
(max img-height height)
|
|
outside-margin))))
|
|
|
|
(define new-bitmap (make-screen-bitmap new-width new-height))
|
|
(define bitmap-dc (make-object bitmap-dc% new-bitmap))
|
|
(send bitmap-dc clear)
|
|
|
|
(send bitmap-dc draw-bitmap
|
|
img-bitmap
|
|
outside-margin
|
|
(- (/ new-height 2) (/ img-height 2))
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(send img-bitmap get-loaded-mask))
|
|
|
|
(send bitmap-dc set-font font)
|
|
(send bitmap-dc draw-text text
|
|
(+ outside-margin img-width middle-margin)
|
|
(- (/ new-height 2) (/ 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)))
|