.

original commit: df00979e3b2372423a295f886b9644c0931aab74

collects/mrlib/bitmap-label.ss

@@ -0,0 +1,94 @@
+(module bitmap-label mzscheme
+  (require (lib "mred.ss" "mred")
+	   (lib "class.ss")
+	   (lib "contract.ss"))
+
+  (provide/contract
+   [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)
+      (lambda (area-container-window)
+	(let*-values ([(outside-margin) 2]
+		      [(font) (send area-container-window get-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))])))