(module editor-canvas-mixins mzscheme (require (lib "contract.ss") (lib "class.ss") (lib "mred.ss" "mred") "interfaces.ss" "util-mixins.ss") (provide/contract [pullable-editor-canvas-mixin (mixin/c [editor-canvas%] [] [pullable<%>])]) (define (pullable-editor-canvas-mixin super%) (class* (ensure-iface editor-canvas-util<%> editor-canvas-util-mixin super%) (pullable<%>) (super-new) (inherit get-editor scroll-to/xy) (override on-event) (public on-pull) (define anchor #f) (define (pulling?) anchor) (define (start? event) (eq? (send event get-event-type) 'left-down)) (define (pull? event) (eq? (send event get-event-type) 'motion)) (define (stop? event) (eq? (send event get-event-type) 'left-up)) (define (start-pull event) (let*-values ([(x y) (send (get-editor) dc-location-to-editor-location (send event get-x) (send event get-y))]) (set! anchor (make-object point% x y)))) (define (pull event) (let* ([event-x (send event get-x)] [event-y (send event get-y)] [anchor-x (send anchor get-x)] [anchor-y (send anchor get-y)]) (on-pull anchor-x anchor-y event-x event-y))) (define (on-pull editor-anchor-x editor-anchor-y dc-event-x dc-event-y) (scroll-to/xy (- editor-anchor-x dc-event-x) (- editor-anchor-y dc-event-y))) (define (stop-pull event) (set! anchor #f)) (define (on-event event) (if (pulling?) (cond [(pull? event) (pull event)] [(stop? event) (stop-pull event)] [else (super on-event event)]) (cond [(start? event) (start-pull event)] [else (super on-event event)]))) )) )