...
original commit: 1df048a69374ad033091abd138c683419cbbfac2
This commit is contained in:
parent
79d491a5f3
commit
58af2f2da6
|
@ -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
|
||||
|
|
|
@ -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 ())
|
||||
|
|
|
@ -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%)))
|
Loading…
Reference in New Issue
Block a user