From 0b4f4c0b1a7bcc33d786c1beb09515ac5868cf99 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 12 Nov 1998 18:15:22 +0000
Subject: [PATCH] .

original commit: ebfed17cbc32f1b8651557e202c3a84731231467
---
 collects/tests/mred/draw-info.txt |  4 ++++
 collects/tests/mred/draw.ss       | 33 ++++++++++++++++++++++++++++++-
 collects/tests/mred/item.ss       | 24 +++++++++++++++++++---
 3 files changed, 57 insertions(+), 4 deletions(-)

diff --git a/collects/tests/mred/draw-info.txt b/collects/tests/mred/draw-info.txt
index a2800f19..97e4e365 100644
--- a/collects/tests/mred/draw-info.txt
+++ b/collects/tests/mred/draw-info.txt
@@ -28,6 +28,10 @@ The drawing area should have the following features:
     be black for the left colum, and green for the remaining two
     columns.
 
+  Under the three columns of boxes, a black box should be filled with
+    an 25% black B&W bitmap, and a red box frame should be draw with a
+    50% red stipple.
+
   The drawings under "0 x 0" and "1 x 1" should look nearly the same:
 
     TopLeft: h-line should be left-aligned with box below it, but
diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss
index 0ae4c1df..c765106b 100644
--- a/collects/tests/mred/draw.ss
+++ b/collects/tests/mred/draw.ss
@@ -36,6 +36,16 @@
 	(make-object point% 0 120)
 	(make-object point% 60 60)))
 
+(define (get-b&w-light-stipple)
+  (make-object bitmap%
+	       (list->string (map integer->char '(#x88 0 #x22 0 #x88 0 #x22 0)))
+	       8 8))
+
+(define (get-b&w-half-stipple)
+  (make-object bitmap%
+	       (list->string (map integer->char '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33)))
+	       8 8))
+
 (let* ([f (make-object frame% "Graphics Test" #f 300 450)]
        [vp (make-object vertical-panel% f)]
        [hp0 (make-object horizontal-panel% vp)]
@@ -343,8 +353,29 @@
 				    (send dc set-brush ob)
 				    (loop x (+ y 25) (cdr l)))))
 
-			      (send dc set-pen op))
+			      (send dc set-pen op)
 
+			      ; B&W 8x8 stipple:
+			      (unless no-bitmaps?
+				(let ([bml (get-b&w-light-stipple)]
+				      [bmh (get-b&w-half-stipple)]
+				      [orig-b (send dc get-brush)]
+				      [orig-pen (send dc get-pen)])
+				  (send dc set-brush brusht)
+				  (send dc set-pen pen1s)
+				  (send dc draw-rectangle 244 164 18 18)
+				  (send dc draw-bitmap bml 245 165)
+				  (send dc draw-bitmap bml 245 173)
+				  (send dc draw-bitmap bml 253 165)
+				  (send dc draw-bitmap bml 253 173)
+
+				  (let ([p (make-object pen% "RED" 1 'solid)])
+				    (send p set-stipple bmh)
+				    (send dc set-pen p)
+				    (send dc draw-rectangle 270 164 18 18))
+
+				  (send dc set-brush orig-b)
+				  (send dc set-pen orig-pen))))
 			    
 			    (when (and (not no-bitmaps?) last?)
 			      (let ([x 5] [y 165])
diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss
index a8636f17..f0dbafc3 100644
--- a/collects/tests/mred/item.ss
+++ b/collects/tests/mred/item.ss
@@ -3,6 +3,7 @@
 
 (define my-txt #f)
 (define my-lb #f)
+(define noisy? #f)
 
 (define special-font (send the-font-list find-or-create-font
 			   20 'decorative 
@@ -75,6 +76,19 @@
 	   (or (and m? (send cm get-value))
 	       (and (not m?) (send ck get-value)))))))
 
+(define (add-enter/leave-note frame panel)
+  (define m (make-object message% "enter: ??????????????????????????????" panel))
+  (lambda (win e)
+    (when (memq (send e get-event-type) '(enter leave))
+      (let ([s (format "~a: ~a"
+		    (send e get-event-type)
+		    (let ([l (send win get-label)])
+		      (if (not l)
+			  win
+			  l)))])
+	(when noisy? (printf "~a~n" s))
+	(send m set-label s)))))
+
 (define (add-cursors frame panel ctls)
   (let ([old #f]
 	[f-old #f]
@@ -174,10 +188,13 @@
 
 (define active-frame%
   (class-asi frame%
-    (private (pre-on void))
+    (private 
+      [pre-on void]
+      [el void])
     (rename [super-on-subwindow-event on-subwindow-event]
 	    [super-on-subwindow-char on-subwindow-char])
     (override [on-subwindow-event (lambda args 
+				    (apply el args)
 				    (or (apply pre-on args)
 					(apply super-on-subwindow-event args)))]
 	      [on-subwindow-char (lambda args 
@@ -187,7 +204,8 @@
 	      [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
     (public [set-info
 	     (lambda (ep)
-	       (set! pre-on (add-pre-note this ep)))])))
+	       (set! pre-on (add-pre-note this ep))
+	       (set! el (add-enter/leave-note this ep)))])))
 
 (define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?)
   
@@ -1561,7 +1579,7 @@
       (make-object radio-box% "Label Font" '("Normal" "Big")
 		    p1 void))
     (define button-font-radio
-      (make-object radio-box% "Button Font" '("Normal" "Big")
+      (make-object radio-box% "Control Font" '("Normal" "Big")
 		    p1 void))
     (define next-button
       (make-next-button p2 (list radio-h-radio label-h-radio label-null-radio