diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 04db45f6..ca811447 100644 --- a/collects/framework/frame.ss +++ b/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 diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 2d82ed20..95651abe 100644 --- a/collects/framework/frameworks.ss +++ b/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 ()) diff --git a/collects/framework/panel.ss b/collects/framework/panel.ss index 99955ee0..64a3114a 100644 --- a/collects/framework/panel.ss +++ b/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%))) \ No newline at end of file + (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%))) \ No newline at end of file