From 78af8e7be3b7fc9988d1b57329fa066eeb3f0b1b Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 11 Apr 1998 17:44:15 +0000
Subject: [PATCH] cursors and focus

original commit: ba5a1bd843081201797fb3a4c66f72541555ce79
---
 collects/tests/mred/item.ss | 130 ++++++++++++++++++++++++------------
 1 file changed, 88 insertions(+), 42 deletions(-)

diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss
index ae046875..93813b64 100644
--- a/collects/tests/mred/item.ss
+++ b/collects/tests/mred/item.ss
@@ -55,26 +55,59 @@
 	 (lambda ()
 	   (when (send frame is-shown?)
 	     (send m set-label
-		   (format "focus: ~s" (mred:test:get-focused-window)))
+		   (let* ([w (mred:test:get-focused-window)]
+			  [l (and w (send w get-label))])
+		     (format "focus: ~a ~a" (or l "") w)))
 	     (start 1000 #t)))])))
    start 1000 #t))
 
 (define (add-pre-note frame panel)
   (define m (make-object mred:message% panel "pre: ??????????????????????????????"))
-  (define c (make-object mred:check-box% panel void "Drop Events"))
+  (define cm (make-object mred:check-box% panel void "Drop Mouse Events"))
+  (define ck (make-object mred:check-box% panel void "Drop Key Events"))
   (lambda (win e)
-    (send m set-label
-	  (format "pre: ~s ~s ~s"
-		  (if (is-a? e wx:mouse-event%)
-		      "mouse"
-		      "key")
-		  win
-		  (if (eq? win (send e get-event-object))
-		      ""
-		      "BAD")))
-    (and (not (eq? win c))
-	 (send c get-value))))
+    (let ([m? (is-a? e wx:mouse-event%)])
+      (send m set-label
+	    (format "pre: ~a ~a ~a"
+		    (if m? "mouse" "key")
+		    (let ([l (send win get-label)])
+		      (if (null? l)
+			  win
+			  l))
+		    (if (eq? win (send e get-event-object))
+			""
+			"BAD")))
+      (and (not (or (eq? win cm) (eq? win ck)))
+	   (or (and m? (send cm get-value))
+	       (and (not m?) (send ck get-value)))))))
 
+(define (add-cursors frame panel ctls)
+  (let ([old #f]
+	[f-old #f]
+	[bc (make-object wx:cursor% wx:const-cursor-bullseye)]
+	[cc (make-object wx:cursor% wx:const-cursor-cross)])
+    (make-object mred:check-box% panel
+		 (lambda (c e)
+		   (if (send c get-value)
+		       (set! old 
+			     (map (lambda (b) (send b set-cursor bc))
+				  ctls))
+		       (map (lambda (b c) (send b set-cursor c))
+			    ctls old)))
+		 "Bullseye Cursors")
+    (make-object mred:check-box% panel
+		 (lambda (c e)
+		   (if (send c get-value)
+		       (set! f-old (send frame set-cursor cc))
+		       (send frame set-cursor f-old)))
+		 "Frame Cross Cursor")
+    (make-object mred:check-box% panel
+		 (lambda (c e)
+		   (if (send c get-value)
+		       (wx:begin-busy-cursor)
+		       (wx:end-busy-cursor)))
+		 "Busy Cursor")))
+		       
 (define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")
 
 (define-values (icons-path local-path)
@@ -138,6 +171,15 @@
       (unless (ok?)
 	(printf "bitmap failure: ~s~n" args)))))
 
+(define active-frame%
+  (class-asi mred:frame%
+     (private (pre-on void))
+     (public [pre-on-event (lambda args (apply pre-on args))]
+	     [pre-on-char pre-on-event]
+	     [set-info
+	      (lambda (ep)
+		(set! pre-on (add-pre-note this ep)))])))
+
 (define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?)
   
   (define return-bmp 
@@ -216,7 +258,7 @@
 			   -1 -1 -1 -1))
   
   (set! my-txt txt)
-  
+
   (add-testers "Button" b)
   (add-change-label "Button" b lp #f OTHER-LABEL)
   
@@ -249,31 +291,28 @@
   (add-testers "Text" txt)
   (add-change-label "Text" txt lp #f OTHER-LABEL)
   
-  (make-object popup-test-canvas% 
-	       (list l il 
-		     b ib
+  (let ([items (list l il 
+		     b ib 
 		     lb
-		     cb icb
-		     rb irb
+		     cb icb 
+		     rb irb 
 		     ch
-		     txt)
-	       (list "label" "image label"
-		     "button" "image button"
-		     "list box"
-		     "checkbox" "image checkbox"
-		     "radio box" "image radiobox"
-		     "choice"
-		     "text")
-	       cp))
+		     txt)])
+    (cons (make-object popup-test-canvas% 
+		       items
+		     (list "label" "image label"
+			   "button" "image button"
+			   "list box"
+			   "checkbox" "image checkbox"
+			   "radio box" "image radiobox"
+			   "choice"
+			   "text")
+		     cp)
+	  items)))
 
 (define (big-frame h-radio? v-label? null-label? stretchy? special-font?)
-  (define pre-on void)
-
-  (define f (make-object 
-	     (class-asi mred:frame%
-			(public [pre-on-event (lambda args (apply pre-on args))]
-				[pre-on-char pre-on-event]))
-	     null "Tester"))
+  (define f (make-object active-frame%
+			 null "Tester"))
   
   (define hp (make-object mred:horizontal-panel% f))
   
@@ -307,18 +346,19 @@
   (when special-font?
     (send tp set-label-font special-font))
     
-  (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy?)
-  
-  (add-focus-note f ep)
-  (set! pre-on (add-pre-note f ep))
+  (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy?)])
+    (add-focus-note f ep)
+    (send f set-info ep)
+    
+    (add-cursors f lp ctls))
 
   (send f show #t)
   (set! prev-frame f)
   f)
 
 (define (med-frame radio-h? label-h? null-label? stretchy? special-font?)
-  (define f2 (make-object mred:frame% null "Tester2"))
-  
+  (define f2 (make-object active-frame% null "Tester2"))
+
   (define hp2 (make-object mred:horizontal-panel% f2))
   
   (define ip2 (make-object mred:vertical-panel% hp2))
@@ -401,7 +441,13 @@
     (add-change-label "Text" txt lp2 #f OTHER-LABEL)
     
     (add-focus-note f2 ep2)
-    
+    (send f2 set-info ep2)
+
+    (add-cursors f2 lp2 (list sh sv
+			      gh gv
+			      cmt cmi 
+			      txt))
+
     (send f2 show #t)
     (set! prev-frame f2)
     f2))