fixed bugs, added mred:message-box

original commit: bbb55e4980c850eb15afc4f0d1a1e23e6d077572

collects/mred/edit.ss

@@ -37,6 +37,21 @@
 	    [super-set-max-width set-max-width]
 	    [super-lock lock])
 
+	  (public
+	    [get-edit-snip
+	     (lambda () (make-object wx:media-snip%
+			  (make-object edit%)))]
+	    [get-pasteboard-snip
+	     (lambda () (make-object wx:media-snip%
+			  (make-object pasteboard%)))]
+	    [on-new-box
+	     (lambda (type)
+	       (wx:message-box (format "insert-box ~a" type))
+	       (cond
+		 [(= type wx:const-edit-buffer)
+		  (get-edit-snip)]
+		 [else (get-pasteboard-snip)]))])
+
 	  (private
 	    [auto-saved-name #f]
 	    [auto-save-out-of-date? #t]
@@ -44,7 +59,7 @@
 	  (public
 	    [set-max-width
 	     (lambda (x)
-	       (mred:debug:printf 'rewrap "set-max-width: ~a~n" x)
+	       (mred:debug:printf 'rewrap "set-max-width: ~a" x)
 	       (super-set-max-width x))]
 	    [get-file (lambda (d) 
 			(let ([v (mred:finder:get-file d)])
@@ -59,7 +74,7 @@
 	    [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)]
 	    [set-auto-set-wrap
 	     (lambda (v)
-	       (mred:debug:printf 'rewrap "set-auto-set-wrap: ~a~n" v)
+	       (mred:debug:printf 'rewrap "set-auto-set-wrap: ~a" v)
 	       (set! auto-set-wrap? v)
 	       (rewrap))]
 	    
@@ -67,12 +82,12 @@
 	     (let ([do-wrap
 		    (lambda (new-width)
 		      (let ([current-width (get-max-width)])
-			(mred:debug:printf 'rewrap "do-wrap: new-width ~a  current-width ~a~n" new-width current-width)
+			(mred:debug:printf 'rewrap "do-wrap: new-width ~a  current-width ~a" new-width current-width)
 			(unless (or (= current-width new-width)
 				    (and (<= current-width 0)
 					 (<= new-width 0)))
 			  (set-max-width new-width)
-			  (mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a~n" 
+			  (mred:debug:printf 'rewrap "attempted to wrap to: ~a actually wrapped to ~a" 
 					     new-width (get-max-width)))))])
 	       (lambda ()
 		 (if auto-set-wrap?
@@ -91,7 +106,7 @@
 			     (max (unbox w-box) sofar)))
 			 0
 			 canvases)))
-		     (do-wrap -1))))]
+		     (do-wrap 0))))]
 	    [mode #f]
 	    [set-mode
 	     (lambda (m)

collects/mred/finder.ss

@@ -323,7 +323,8 @@
 	  (when (eq? wx:platform 'unix)
 	    (make-object mred:container:check-box% period-panel
 			 do-period-in/exclusion
-			 "Show files and directories that begin with a period"))
+			 "Show files and directories that begin with a period")
+	    (send period-panel stretchable-in-y #f))
 
 	  (send* directory-panel 
 	    (stretchable-in-y #f)
@@ -345,7 +346,6 @@
 	    (send add-panel stretchable-in-y #f)
 	    (send remove-panel stretchable-in-y #f)
 	    (send result-list stretchable-in-x #t))
-	  (send period-panel stretchable-in-y #f)
 	  (send name-list stretchable-in-x #t)
 	  (send top-panel stretchable-in-y #f)
 	  (send bottom-panel stretchable-in-y #f)

collects/mred/panel.ss

@@ -11,48 +11,35 @@
       (lambda (super%)
 	(class-asi super%
 	  (rename [super-change-children change-children])
-	  (inherit children get-parent)
+	  (inherit get-parent change-children children)
 	  (public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)])
-	  (private
-	    [edit-mapping (make-hash-table)]
-	    [bind
-	     (lambda (panel edit)
-	       (hash-table-put! edit-mapping edit panel))]
-	    [lookup/add
-	     (lambda (child)
-	       (if (is-a? child wx:media-edit%)
-		   (let ([add-new
-			  (lambda ()
-			    (let ([p (make-object (get-canvas%) this)])
-			      (send p set-media child)
-			      (send child add-canvas p)
-			      (bind p child)
-			      p))])
-		     (hash-table-get edit-mapping child add-new))
-		   child))])
 	  (public
-
-	    ; this contains the edits and panels that are children of
-	    ; this panel, but the canvases of these edits are not
-	    ; necessarily immediate children, since they may be split.
-	    [actual-children null]
-	   
 	    [collapse
 	     (lambda (canvas)
 	       (letrec* ([media (send canvas get-media)]
 			 [helper
 			  (lambda (canvas/panel)
-			    (let* ([parent (send canvas/panel get-parent)])
+			    (if (eq? canvas/panel this)
-			      (if (is-a? parent wx:frame%)
+				(begin (cond
-				  (begin (send canvas/panel change-children
+					 [(and (= (length children) 1)
-					       (lambda (l) (list media)))
+					       (eq? canvas (car children)))
+					  (void)]
+					 [(member canvas children)
+					  (change-children (lambda (l) (list canvas)))]
+					 [else
+					  (change-children
+					   (lambda (l)
+					     (let ([c (make-object (object-class canvas) this)])
+					       (send c set-media media)
+					       (list c))))])
 				       (wx:bell))
-				  (let* ([parents-children (ivar parent children)]
+				(let* ([parent (send canvas/panel get-parent)]
+				       [parents-children (ivar parent children)]
 				       [num-children (length parents-children)])
 				  (if (<= num-children 1)
 				      (helper parent)
 				      (begin (send parent delete-child canvas/panel)
-					       (send (car (ivar parent children)) set-focus)))))))])
+					     (send (car (ivar parent children)) set-focus))))))])
 		 (send media remove-canvas canvas)
 		 (helper canvas)))]
 
@@ -83,16 +70,7 @@
 			(add-canvas left-split)
 			(add-canvas right-split))
 		 (send* left-split (set-media media) (set-focus))
-		 (send* right-split (set-media media))
+		 (send* right-split (set-media media))))]))))
-		 (when (eq? this parent)
-		   (bind media new-panel))))]
-	    [change-children
-	     (lambda (f)
-	       (let ([new-children (f actual-children)])
-		 (super-change-children (lambda (l)
-					  (map lookup/add
-					       new-children)))
-		 (set! actual-children new-children)))]))))
     
     (define horizontal-edit-panel%
       (make-edit-panel% mred:container:horizontal-panel%))