(module util-mixins mzscheme (require (lib "contract.ss") (lib "class.ss") (lib "mred.ss" "mred") "interfaces.ss") (provide/contract [editor-util-mixin (mixin/c [editor<%>] [] [editor-util<%>])] [pasteboard-util-mixin (mixin/c [pasteboard%] [] [pasteboard-util<%>])] [editor-canvas-util-mixin (mixin/c [editor-canvas%] [] [editor-canvas-util<%>])] ) (define (editor-util-mixin super%) (class* super% (editor-util<%>) (super-new) (inherit get-admin dc-location-to-editor-location get-view-size) (public scroll-to/xy get-position vertical-scroll-step horizontal-scroll-step) (define (get-position) (let*-values ([(x y) (dc-location-to-editor-location 0 0)] [(w) (box 0)] [(h) (box 0)]) (get-view-size w h) (values x y (unbox w) (unbox h)))) (define (vertical-scroll-step) (if (is-a? this pasteboard%) (send this get-scroll-step) 1)) (define (horizontal-scroll-step) 1) (define (scroll-to/xy new-x new-y) (let*-values ([(x y w h) (get-position)] [(x-step) (horizontal-scroll-step)] [(y-step) (vertical-scroll-step)]) (send (get-admin) scroll-to (max (+ (or new-x x) (/ x-step 2)) 0) (max (+ (or new-y y) (/ y-step 2)) 0) (max (- w x-step) 0) (max (- h y-step) 0)))) )) (define (pasteboard-util-mixin super%) (class* (ensure-iface editor-util<%> editor-util-mixin super%) (pasteboard-util<%>) (super-new) (inherit insert move get-snip-location) (public center-snip) (define (center-snip snip x y w h) (insert snip (floor x) (floor y)) (let* ([top (box 0)] [lft (box 0)] [bot (box 0)] [rgt (box 0)]) (get-snip-location snip top lft #f) (get-snip-location snip bot rgt #t) (let* ([snip-w (- (unbox rgt) (unbox lft))] [snip-h (- (unbox bot) (unbox top))] [dx (/ (- w snip-w) 2)] [dy (/ (- h snip-h) 2)]) (move snip (floor dx) (floor dy))))) )) (define (editor-canvas-util-mixin super%) (class* super% (editor-canvas-util<%>) (super-new) (inherit get-editor get-client-size scroll-to) (public scroll-to/xy on-scroll/xy get-position) (override on-paint) (define (get-position) (let*-values ([(x y) (send (get-editor) dc-location-to-editor-location 0 0)] [(w h) (get-client-size)]) (values x y w h))) (define (scroll-to/xy new-x new-y) (let*-values ([(x y w h) (get-position)] [(x-step) 1] [(y-step) (let* ([editor (get-editor)]) (if (is-a? editor pasteboard%) (send editor get-scroll-step) 1))]) (scroll-to (max (+ (or new-x x) (/ x-step 2)) 0) (max (+ (or new-y y) (/ y-step 2)) 0) (max (- w x-step) 0) (max (- h y-step) 0) #t))) (define (on-scroll/xy x y dx dy) (void)) (define saved-x 0) (define saved-y 0) (define (on-paint) (super on-paint) (let*-values ([(x y w h) (get-position)]) (unless (and (= x saved-x) (= y saved-y)) (let* ([dx (- x saved-x)] [dy (- y saved-y)]) (set! saved-x x) (set! saved-y y) (on-scroll/xy x y dx dy))))) )) )