...

original commit: 1df048a69374ad033091abd138c683419cbbfac2

collects/framework/frame.ss

@@ -567,6 +567,7 @@
 		       get-editor%
 		       get-editor<%>
 		       
+		       get-canvas-area-container
 		       make-editor
 		       save-as
 		       get-canvas
@@ -779,6 +780,7 @@
 	       args))
 	     
       (public
+	[get-canvas-area-container (lambda () (get-area-container))]
 	[get-canvas (let ([c #f])
 		      (lambda () 
 			(unless c
@@ -800,7 +802,10 @@
 	  (send (get-editor) set-filename file-name)]
 	 [else (void)])
 	(let ([canvas (get-canvas)])
-	  (send canvas focus)))))
+	  (when (is-a? canvas editor-canvas%)
+	    ;; when get-canvas is overridden,
+	    ;; it might not yet be implemented
+	    (send canvas focus))))))
   
   (define text<%> (interface (-editor<%>)))
   (define text-mixin

collects/framework/frameworks.ss

@@ -34,10 +34,14 @@
    ;multi-view-mixin
    ;multi-view<%>
 
+   vertical-resizable<%>
+   vertical-resizable-mixin
+
    single%
    single-pane%
    ;multi-view%
-   ))
+   vertical-resizable%
+   vertical-resizable-pane%))
 
 (define-signature framework:exn^
   ((struct exn ())

collects/framework/panel.ss

@@ -140,4 +140,173 @@
 
   (define single% (single-window-mixin (single-mixin panel%)))
   (define single-pane% (single-mixin pane%))
-  (define multi-view% (multi-view-mixin vertical-panel%)))
+  (define multi-view% (multi-view-mixin vertical-panel%))
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;                                          ;;
+  ;;                 split panel              ;;
+  ;;                                          ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (refresh-panel panel)
+    (let-values ([(ha va) (send panel get-alignment)])
+      (send panel set-alignment ha va)))
+
+  (define thumb-canvas%
+    (class canvas% (parent get-top-min get-bot-min)
+      (private
+	[percentage 1/2])
+      (public
+	[get-percentage (lambda () percentage)]
+	[set-percentage (lambda (_p) 
+			  (set! percentage _p)
+			  (on-paint))])
+      (private
+	[gray-region 18]
+	[canvas-width 18]
+	[thumb-height 16]
+	[thumb-min 16])
+      
+      (private
+	[grabbed? #f]
+	[get-thumb-middle
+	 (lambda ()
+	   (let-values ([(w h) (get-client-size)])
+	     (floor (* h percentage))))]
+	[get-thumb-top
+	 (lambda ()
+	   (- (get-thumb-middle) (/ thumb-height 2)))]
+	[get-thumb-bottom
+	 (lambda ()
+	   (+ (get-thumb-top) thumb-height))]
+	[update-percentage/draw
+	 (lambda (mouse-evt)
+	   (let-values ([(w h) (get-client-size)])
+	     (let* ([y (inexact->exact (send mouse-evt get-y))]
+		    [y-min (max thumb-min (get-top-min))]
+		    [y-max (- h (max thumb-min (get-bot-min)))])
+	       (set! percentage (/ (min (max y-min y) y-max) h))
+	       (on-paint))))])
+      (inherit get-dc get-client-size)
+      (rename [super-on-event on-event])
+      (override
+       [on-event
+	(lambda (evt)
+	  (cond
+	   [(send evt button-down?)
+	    (set! grabbed? #t)
+	    (update-percentage/draw evt)]
+	   [(and grabbed? (send evt button-up?))
+	    (set! grabbed? #f)
+	    (update-percentage/draw evt)
+	    (refresh-panel parent)]
+	   [(and grabbed? (send evt moving?))
+	    (update-percentage/draw evt)]
+	   [else (super-on-event evt)]))]
+       [on-paint
+	(lambda ()
+	  (let ([dc (get-dc)]
+		[panel-color (get-panel-background)])
+	    (let-values ([(w h) (get-client-size)])
+	      (send dc set-pen (send the-pen-list find-or-create-pen panel-color 1 'solid))
+	      (send dc set-brush (send the-brush-list find-or-create-brush panel-color 'solid))
+	      (send dc draw-rectangle 0 0 w h)
+	      
+	      (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+	      (if grabbed?
+		  (send dc set-brush (send the-brush-list find-or-create-brush "blue" 'solid))
+		  (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid)))
+	      (send dc draw-polygon
+		    (list (make-object point% 2 (get-thumb-middle))
+			  (make-object point% (- w 1) (get-thumb-top))
+			  (make-object point% (- w 1) (get-thumb-bottom)))))))])
+      
+      (inherit min-width stretchable-width)
+      (sequence 
+	(super-init parent)
+	(min-width canvas-width)
+	(stretchable-width #f))))
+
+  (define vertical-resizable<%>
+    (interface (area-container<%>)
+      set-percentage))
+      
+  (define vertical-resizable-mixin
+    (mixin (area-container<%>) (vertical-resizable<%>) args
+
+      ;; preserve the invariant that the thumb-canvas is
+      ;; the first child.
+      (rename [super-change-children change-children])
+      (override
+       [change-children
+	(lambda (f)
+	  (super-change-children
+	   (lambda (l)
+	     (let ([res (cons
+			 thumb-canvas
+			 (mzlib:function:filter
+			  (lambda (c) (not (eq? c thumb-canvas)))
+			  (f l)))])
+	       (printf "change-children to ~s~n" res)
+	       res))))])
+
+      (override
+       [container-size
+	(lambda (_lst)
+	  ;; remove the thumb canvas from the computation
+	  (printf "container-size: ~n")
+	  (let ([lst (if (null? _lst) null (cdr _lst))])
+	    (values
+	     (apply + (map car lst))
+	     (cond
+	      [(null? lst) 0]
+	      [(null? (cdr lst)) (cadr (car lst))]
+	      [else
+	       (+ (send thumb-canvas min-width)
+		  (apply max (map cadr lst)))]))))]
+       [place-children
+	(lambda (info width height)
+	  (let* ([percentage (send thumb-canvas get-percentage)]
+		 [first (floor (* percentage height))]
+		 [second (- height first)]
+		 [main-width (- width (send thumb-canvas min-width))]
+		 [res
+		  (cond
+		   [(null? info) null]
+		   [(null? (cdr info)) (list (list 0 0 0 0))]
+		   [(null? (cdr (cdr info)))
+		    (list (list 0 0 0 0)
+			  (list 0 0 width height))]
+		   [else
+		    (list* (list (- width (send thumb-canvas min-width)) 0
+				 (send thumb-canvas min-width)
+				 height)
+			   (list 0 0 main-width first)
+			   (list 0 first main-width second)
+			   (map (lambda (x) (list 0 0 0 0)) (cdddr info)))])])
+
+	    (printf "place-children: ~s~n" res)
+	    res))])
+      (inherit reflow-container get-top-level-window set-alignment get-alignment)
+      (public
+	[set-percentage
+	 (lambda (p)
+	   (send thumb-canvas set-percentage p)
+	   (refresh-panel this))])
+      
+      (sequence
+	(apply super-init args))
+      (inherit get-children)
+      (private
+	[make-get-min
+	 (lambda (index)
+	   (lambda ()
+	     (let* ([children (get-children)])
+	       (if (< index (length children))
+		   (send (list-ref children index) min-height)
+		   0))))]
+	[thumb-canvas (make-object thumb-canvas% this (make-get-min 2) (make-get-min 3))])))
+
+  (define vertical-resizable% (vertical-resizable-mixin panel%))
+  (define vertical-resizable-pane% (vertical-resizable-mixin pane%)))