bring this code in the modern world
(I think the use of bitmaps is the right one here, but this code doesn't actually work, pending PR 11566) original commit: 8bb2543b3403e98644aad2da032f8855055333f2
This commit is contained in:
Robby Findler
parent
399739686d
commit
56a304d3a5
|
|
@ -1,105 +1,74 @@
|
|||
(module bitmap-label mzscheme
|
||||
(require mred
|
||||
mzlib/class
|
||||
mzlib/etc
|
||||
mzlib/contract)
|
||||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/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%)))])
|
||||
(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 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)
|
||||
(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)
|
||||
|
||||
new-bitmap)))
|
||||
|
||||
(define (bitmap-label-maker text filename-or-bitmap)
|
||||
(let ([bm (make-bitmap-label text filename-or-bitmap)])
|
||||
(lambda (area-container-window)
|
||||
bm))))
|
||||
(define (bitmap-label-maker text filename-or-bitmap)
|
||||
(let ([bm (make-bitmap-label text filename-or-bitmap)])
|
||||
(lambda (area-container-window)
|
||||
bm)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user