From 2f10f9757fb1fb5bc2e66985c1cea5e973767123 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 20 May 2003 12:55:58 +0000
Subject: [PATCH] .

original commit: 1cb49e6f33c4aea2f9140018749ab5c19caba0b9
---
 collects/mred/mred.ss       | 38 +++++++++++++++++++++++--------------
 collects/tests/mred/item.ss | 34 ++++++++++++++++++++++++++++++---
 2 files changed, 55 insertions(+), 17 deletions(-)

diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss
index 843db0dc..15d838c6 100644
--- a/collects/mred/mred.ss
+++ b/collects/mred/mred.ss
@@ -3438,11 +3438,13 @@
       [l (and label
 	      (make-object wx-message% #f proxy p label -1 -1 null))]
       [c (make-object wx-text-editor-canvas% #f proxy this p
-		      (if multi?
-			  (if (memq 'hscroll style)
-			      null
-			      '(hide-hscroll))
-			  '(hide-vscroll hide-hscroll)))])
+		      (append
+		       '(control-border)
+		       (if multi?
+			   (if (memq 'hscroll style)
+			       null
+			       '(hide-hscroll))
+			   '(hide-vscroll hide-hscroll))))])
     (sequence
       (send c set-x-margin 2)
       (send c set-y-margin 2)
@@ -4704,6 +4706,10 @@
 ;-------------------- Canvas class constructions --------------------
 
 (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
+(define canvas-scroll-size 10)
+(define canvas-control-border-extra (case (system-type)
+				      [(windows) 2]
+				      [else 0]))
 
 (define canvas<%>
   (interface (subwindow<%>)
@@ -4750,7 +4756,7 @@
     (sequence 
       (let ([cwho '(constructor canvas)])
 	(check-container-parent cwho parent)
-	(check-style cwho #f '(border hscroll vscroll gl deleted) style)
+	(check-style cwho #f '(border hscroll vscroll gl deleted control-border no-autoclear) style)
 	(check-callback cwho paint-callback)
 	(check-label-string/false cwho label)))
     (public
@@ -4826,9 +4832,10 @@
       [wx #f])
     (sequence
       (super-init (lambda () 
-		    (let ([ds (+ (if (memq 'border style)
-				     4 
-				     0)
+		    (let ([ds (+ (cond
+				  [(memq 'control-border style) (+ 4 canvas-control-border-extra)]
+				  [(memq 'border style) 4]
+				  [else 0])
 				 (if (or (memq 'vscroll style) (memq 'hscroll style))
 				     canvas-default-size
 				     1))])
@@ -4861,7 +4868,7 @@
       (let ([cwho '(constructor editor-canvas)])
 	(check-container-parent cwho parent)
 	(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
-	(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted) style)
+	(check-style cwho #f '(hide-vscroll hide-hscroll no-vscroll no-hscroll deleted control-border) style)
 	(check-gauge-integer cwho scrolls-per-page)
 	(check-label-string/false cwho label)
 	(unless (eq? wheel-step no-val)
@@ -4957,10 +4964,13 @@
 			   [no-v? (or (memq 'no-hscroll style)
 				      (memq 'hide-hscroll style))]
 			   [get-ds (lambda (no-this? no-other?)
-				     (cond
-				      [(and no-this? no-other?) 14]
-				      [no-this? canvas-default-size]
-				      [else (+ 10 canvas-default-size)]))])
+				     (+ (if (memq 'control-border style)
+					    canvas-control-border-extra
+					    0)
+					(cond
+					 [(and no-this? no-other?) 14]
+					 [no-this? canvas-default-size]
+					 [else (+ canvas-scroll-size canvas-default-size)])))])
 		      (set! wx (make-object wx-editor-canvas% this this
 					    (mred->wx-container parent) -1 -1
 					    (get-ds no-h? no-v?)
diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss
index 2eada617..4b0cf67b 100644
--- a/collects/tests/mred/item.ss
+++ b/collects/tests/mred/item.ss
@@ -546,7 +546,7 @@
   
   (define fp (make-object vertical-panel% ip))
   
-  (define tp (make-object vertical-panel% fp))
+  (define tp (make-object group-box-panel% "Sub" fp))
 
   (when initially-disabled?
     (send tp enable #f))
@@ -601,8 +601,8 @@
 	  (basic-add-testers2 name control))
 	basic-add-testers2))
 
-  (define fp2 (make-object vertical-panel% ip2-0))  
-  (define ip2 (make-object vertical-panel% fp2))
+  (define fp2 (make-object vertical-panel% ip2-0))
+  (define ip2 (make-object group-box-panel% "Sub" fp2))
 
   (when initially-disabled?
     (send ip2 enable #f))
@@ -1717,6 +1717,31 @@
   (send f create-status-line)
   (send f show #t))
 
+(define (no-clear-canvas-frame)
+  (define f (make-frame frame% "No-Clear Canvas Test" #f #f 250))
+  (define p (make-object vertical-panel% f))
+  (define c% (class canvas%
+               (inherit get-dc refresh)
+	       (define/override (on-paint)
+		 (let ([red (send the-brush-list find-or-create-brush "RED" 'solid)]
+		       [blue (send the-brush-list find-or-create-brush "BLUE" 'solid)]
+		       [dc (get-dc)])
+		   (let loop ([x 0])
+		     (unless (= x 300)
+		       (send dc set-brush red)
+		       (send dc draw-rectangle x 0 25 400)
+		       (send dc set-brush blue)
+		       (send dc draw-rectangle (+ x 25) 0 25 400)
+		       (loop (+ x 50))))))
+	       (define/override (on-event evt)
+		 (when (send evt dragging?)
+		   (refresh)))
+	       (super-new)))
+  (new c% [parent p][style '(border)])
+  (new c% [parent p][style '(no-autoclear border)])
+  (send f show #t)
+  f)
+
 (define (editor-canvas-oneline-frame)
   (define f (make-frame frame% "x" #f 200 #f))
   
@@ -2006,6 +2031,9 @@
   (mkf '(vscroll) "V")
   (mkf null "")
   (make-object grow-box-spacer-pane% cnp))
+(make-object button%
+	     "Make No-Clear Canvas" cnp 
+	     (lambda (b e) (no-clear-canvas-frame)))
 
 (define (choose-next radios)
   (let loop ([l radios])