initial Scribble search support

svn: r7738

original commit: 3ca803a6de8ff8d096cfbd968adcbe32b5ba8aaf

collects/tests/mred/item.ss

@@ -1,4 +1,6 @@
 
+#lang scheme/gui
+
 (require (lib "class.ss")
 	 (lib "class100.ss")
 	 (lib "etc.ss"))
@@ -184,7 +186,7 @@
 (define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")
 
 (define-values (icons-path local-path)
-  (let ([d (current-load-relative-directory)])
+  (let ([d (this-expression-source-directory)])
     (values
      (lambda (n)
        (build-path (collection-path "icons") n))
@@ -223,7 +225,7 @@
 	     (send dc draw-text "Tab in" 0 60))))]
       [on-event
        (lambda (e)
-	 (if (send e button-down?)
+	 (when (send e button-down?)
 	     (let ([x (send e get-x)]
 		   [y (send e get-y)]
 		   [m (if (or (null? last-m)
@@ -289,7 +291,7 @@
 
 (define prev-frame #f)
 
-(define bitmap%
+(define bitmap2%
   (class100 bitmap% args
     (inherit ok?)
     (sequence
@@ -298,29 +300,27 @@
 	(printf "bitmap failure: ~s~n" args)))))
 
 (define (active-mixin %)
-  (class100-asi %
+  (class %
-    (private-field
+    (define pre-on void)
-      [pre-on void]
+    (define click-i void)
-      [click-i void]
+    (define el void)
-      [el void])
+    (override* [on-subwindow-event (lambda args 
-    (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 click-i args)
-					(super-on-subwindow-event . args)))]
+                                         (super on-subwindow-event . args)))]
                [on-subwindow-char (lambda args 
                                     (or (apply pre-on args)
-				       (super-on-subwindow-char . args)))]
+                                        (super on-subwindow-char . args)))]
                [on-activate (lambda (on?) (printf "active: ~a~n" on?))]
                [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
                [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
-    (public [set-info
+    (public* [set-info
               (lambda (ep)
                 (set! pre-on (add-pre-note this ep))
                 (set! click-i (add-click-intercept this ep))
-	       (set! el (add-enter/leave-note this ep)))])))
+                (set! el (add-enter/leave-note this ep)))])
+    (super-new)))
 
 (define active-frame% (active-mixin frame%))
 (define active-dialog% (active-mixin dialog%))
@@ -339,13 +339,13 @@
       (apply super-init name args))))
 
 (define return-bmp 
-  (make-object bitmap% (icons-path "return.xbm") 'xbm))
+  (make-object bitmap2% (icons-path "return.xbm") 'xbm))
 (define bb-bmp
-  (make-object bitmap% (icons-path "bb.gif") 'gif))
+  (make-object bitmap2% (icons-path "bb.gif") 'gif))
 (define mred-bmp
-  (make-object bitmap% (icons-path "mred.xbm") 'xbm))
+  (make-object bitmap2% (icons-path "mred.xbm") 'xbm))
 (define nruter-bmp
-  (make-object bitmap% (local-path "nruter.xbm") 'xbm))
+  (make-object bitmap2% (local-path "nruter.xbm") 'xbm))
 
 (define (add-label-direction label-h? l)
   (if (not label-h?)
@@ -1398,18 +1398,15 @@
 			    (set! actual-content null)
 			    (set! actual-user-data null)
 			    (send c clear))))
+  (define (gone l n)
+    (if (zero? n)
+        (cdr l)
+        (cons (car l) (gone (cdr l) (sub1 n)))))
   (define (delete p)
     (send c delete p)
     (when (<= 0 p (sub1 (length actual-content)))
-      (if (zero? p)
+      (set! actual-content (gone actual-content p))
-	  (begin
+      (set! actual-user-data (gone actual-user-data p))))
-	    (set! actual-content (cdr actual-content))
-	    (set! actual-user-data (cdr actual-user-data)))
-	  (begin
-	    (set-cdr! (list-tail actual-content (sub1 p)) 
-		      (list-tail actual-content (add1 p)))
-	    (set-cdr! (list-tail actual-user-data (sub1 p)) 
-		      (list-tail actual-user-data (add1 p)))))))
   (define db (if list?
 		 (make-object button%
 			      "Delete" cdp
@@ -1646,22 +1643,20 @@
 (define (canvas-frame flags)
   (define f (make-frame frame% "Canvas Test" #f #f 250))
   (define p (make-object vertical-panel% f))
-  (define c% (class100 canvas% (-name -swapped-name p)
+  (define c% (class canvas%
+               (init -name -swapped-name p)
 	       (inherit get-dc get-scroll-pos get-scroll-range get-scroll-page
 			get-client-size get-virtual-size get-view-start)
-	       (rename [super-init-manual-scrollbars init-manual-scrollbars]
+	       (define name -name)
-		       [super-init-auto-scrollbars init-auto-scrollbars])
+               (define swapped-name -swapped-name)
-	       (private-field
+               (define auto? #f)
-		 [name -name]
+               (define incremental? #f)
-		 [swapped-name -swapped-name]
+               (define vw 10)
-		 [auto? #f]
+               (define vh 10)
-		 [incremental? #f]
+	       (public*
-		 [vw 10]
-		 [vh 10])
-	       (public
 		 [inc-mode (lambda (x) (set! incremental? x))]
 		 [set-vsize (lambda (w h) (set! vw w) (set! vh h))])
-	       (override
+	       (override*
 		[on-paint
 		 (lambda ()
 		   (let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s"
@@ -1697,12 +1692,11 @@
 		   (unless incremental? (on-paint)))]
 		[init-auto-scrollbars (lambda x
 					(set! auto? #t)
-					(super-init-auto-scrollbars . x))]
+					(super init-auto-scrollbars . x))]
 		[init-manual-scrollbars (lambda x
 					  (set! auto? #f)
-					  (super-init-manual-scrollbars . x))])
+					  (super init-manual-scrollbars . x))])
-	       (sequence
+               (super-init p flags)))
-		 (super-init p flags))))
   (define un-name "Unmanaged scroll")
   (define m-name "Automanaged scroll")
   (define c1 (make-object c% un-name m-name p))
@@ -2118,15 +2112,15 @@
 	 (super-init)
 	 (start 1000 #t))))))
 
-(define bp (make-object vertical-panel% ap '(border)))
+(define bp0 (make-object vertical-panel% ap '(border)))
-(define bp1 (make-object horizontal-panel% bp))
+(define bp1 (make-object horizontal-panel% bp0))
-(define bp2 (make-object horizontal-pane% bp))
+(define bp2 (make-object horizontal-pane% bp0))
 (define mp (make-object vertical-panel% ap '(border)))
 (define mp1 (make-object horizontal-panel% mp))
 (define mp2 (make-object horizontal-pane% mp))
 
 (define pp (make-object horizontal-pane% ap))
-(send bp stretchable-height #f)
+(send bp0 stretchable-height #f)
 (make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
 (make-object horizontal-pane% pp)
 (make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame)))