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

merged 1227:1237 -- another draft of initial language. hope this one is better

Browse Source 
svn: r1238

original commit: 3535a75479482503666efaf22490c010fa83b2a5
This commit is contained in:
Robby Findler 2005-11-06 03:29:26 +00:00
parent 9860386e45
commit 9a037694a0
1 changed files with 91 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

173
collects/mrlib/bitmap-label.ss
View File

@ -1,94 +1,103 @@
(module bitmap-label mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "contract.ss"))
(lib "etc.ss")
(lib "contract.ss"))
(provide/contract
[make-bitmap-label (opt->
(string?
(union path-string?
(is-a?/c bitmap%)))
((is-a?/c font%))
(is-a?/c bitmap%))]
[bitmap-label-maker (string?
(union path-string?
(is-a?/c bitmap%))
. -> .
(any/c . -> . (is-a?/c bitmap%)))])
(define bitmap-label-maker
(case-lambda
[(text filename-or-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))
(send bitmap-dc draw-rectangle
(+ outside-margin img-width middle-margin)
(- (/ new-height 2) (/ height 2))
width 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)
(let*-values ([(outside-margin) 2]
[(font) normal-control-font]
[(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))
(send bitmap-dc draw-rectangle
(+ outside-margin img-width middle-margin)
(- (/ new-height 2) (/ height 2))
width height)
(send bitmap-dc draw-bitmap
img-bitmap
outside-margin
(- (/ new-height 2) (/ img-height 2)))
(send bitmap-dc set-bitmap #f)
new-bitmap))])))
bm))))