(module editor-util mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "mred.ss" "mred"))
(define canvas/c (is-a?/c editor-canvas%))
(define admin/c (is-a?/c editor-admin%))
(define editor/c (is-a?/c editor<%>))
(define pasteboard/c (is-a?/c pasteboard%))
(define snip/c (is-a?/c snip%))
(define opt-real/c (or/c false/c real?))
(provide/contract
[scroll-editor-to/xy (editor/c opt-real/c opt-real/c . -> . void?)]
[scroll-canvas-to/xy (canvas/c opt-real/c opt-real/c . -> . void?)]
[get-editor-scroll-step (editor/c . -> . natural-number/c)]
[admin-position (admin/c . -> . (values real? real? real? real?))]
[editor-position (editor/c . -> . (values real? real? real? real?))]
[canvas-position (canvas/c . -> . (values real? real? real? real?))]
[center-snip (pasteboard/c snip/c real? real? real? real? . -> . void?)])
(define (scroll-editor-to/xy editor new-x new-y)
(let*-values ([(x-step) 1] [(y-step) (get-editor-scroll-step editor)]
[(x y w h) (editor-position editor)])
(scroll-editor-to
editor
(max (+ (or new-x x) (/ x-step 2)) 0)
(max (+ (or new-y y) (/ y-step 2)) 0)
(max (- w (* x-step 1)) 0)
(max (- h (* y-step 1)) 0))
(void)))
(define (scroll-canvas-to/xy canvas x y)
(scroll-editor-to/xy (send canvas get-editor) x y))
(define (scroll-editor-to editor x y w h)
(send (send editor get-admin) scroll-to x y w h))
(define (get-editor-scroll-step editor)
(if (is-a? editor pasteboard%)
(send editor get-scroll-step)
1))
(define (admin-position admin)
(let* ([x (box 0)]
[y (box 0)]
[w (box 0)]
[h (box 0)])
(send admin get-view x y w h)
(values (unbox x) (unbox y) (unbox w) (unbox h))))
(define (editor-position editor)
(admin-position (send editor get-admin)))
(define (canvas-position canvas)
(editor-position (send canvas get-editor)))
(define (center-snip pasteboard snip x y w h)
(send pasteboard insert snip (floor x) (floor y))
(let* ([top (box 0)]
[lft (box 0)]
[bot (box 0)]
[rgt (box 0)])
(send pasteboard get-snip-location snip top lft #f)
(send pasteboard 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)])
(send pasteboard move snip (floor dx) (floor dy)))))
)