(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)])))

      ))

  )