(module easel mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "mrpict.ss" "texpict")
"interfaces.ss")
(define easel<%>
(interface ()
get-dx
get-dy
get-bbox
translate
paint-pict))
(provide/contract
[easel<%> interface?]
[easel-dc-wrapper% (class/c easel<%>)])
(define MIN-X -16383)
(define MAX-X +16383)
(define MIN-Y -16383)
(define MAX-Y +16383)
(define easel-dc-wrapper%
(class* object% (easel<%>)
(super-new)
(init [(init-dc dc)]
[(init-dx dx) 0]
[(init-dy dy) 0]
[left MIN-X]
[top MIN-Y]
[right MAX-X]
[bottom MAX-Y]
)
(define dc init-dc)
(define dx init-dx)
(define dy init-dy)
(define dc-left left)
(define dc-top top)
(define dc-right right)
(define dc-bottom bottom)
(public get-dx get-dy get-bbox translate paint-pict)
(private x-to-dc y-to-dc x-from-dc y-from-dc verify!)
(define (x-to-dc x) (+ x dx))
(define (y-to-dc y) (+ y dy))
(define (x-from-dc x) (- x dx))
(define (y-from-dc y) (- y dy))
(define (verify! method description x y)
(unless (and (<= MIN-X x MAX-X) (<= MIN-Y y MAX-Y))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "easel<%>.~s: ~s out of bounds (~s,~s)"
method description x y))
(current-continuation-marks)))))
(define (get-dx) dx)
(define (get-dy) dy)
(define (get-bbox)
(values (x-from-dc dc-left)
(y-from-dc dc-top)
(x-from-dc dc-right)
(y-from-dc dc-bottom)))
(define (translate xoffset yoffset)
(new easel-dc-wrapper%
[dc dc]
[dx (+ dx xoffset)]
[dy (+ dy yoffset)]))
(define (paint-pict x y pict)
(let* ([x (x-to-dc x)]
[y (y-to-dc y)]
[w (pict-width pict)]
[h (pict-height pict)])
(verify! 'paint-pict "top left corner of pict" x y)
(verify! 'paint-pict "bottom right corner of pict" (+ x w) (+ y h))
(draw-pict pict dc x y)))
))
)