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

      ))

  )