(module snip-mixins mzscheme (require (lib "contract.ss") (lib "class.ss") (lib "mred.ss" "mred") (lib "mrpict.ss" "texpict") "interfaces.ss" "dc-utils.ss" "easel.ss") (provide/contract [updatable-snip-mixin (mixin/c [snip%] [] [updatee<%>])] [custom-snip-mixin (mixin/c [snip%] [] [])]) (define (updatable-snip-mixin super%) (class* super% (updatee<%>) (super-new) (inherit get-admin) (public on-update) (define (on-update) (send (get-admin) resized this #t)))) (define (custom-snip-mixin super%) (unreadable-snip-mixin (simple-draw-snip-mixin (functional-location-snip-mixin (functional-extent-snip-mixin super%))))) (define (unreadable-snip-mixin super%) (class super% (super-new) (inherit set-snipclass) (set-snipclass unreadable-snipclass))) (define (simple-draw-snip-mixin super%) (class super% (super-new) (override-final draw) (public paint) (define (draw dc x y left top right bottom dx dy draw-caret) (parameterize ([dc-for-text-size dc]) (paint (new easel-dc-wrapper% [dc dc] [dx x] [dy y] [left left] [top top] [right right] [bottom bottom])))) (define (paint easel) (void)))) (define (functional-location-snip-mixin super%) (class super% (super-new) (inherit get-admin) (public get-location) (define (get-location) (let* ([editor (send (get-admin) get-editor)] [x1 (box 0)] [x2 (box 0)] [y1 (box 0)] [y2 (box 0)]) (send editor get-snip-location this x1 y1 #f) (send editor get-snip-location this x2 y2 #t) (values x1 y1 (- x2 x1) (- y2 y1)))))) (define (functional-extent-snip-mixin super%) (class super% (super-new) (override-final get-extent) (public extent) (define (get-extent dc x y width-box height-box bottom-box top-box left-box right-box) (let*-values ([(width height bottom top left right) (parameterize ([dc-for-text-size dc]) (extent dc x y))]) (fill-box! width-box width) (fill-box! height-box height) (fill-box! bottom-box bottom) (fill-box! top-box top) (fill-box! left-box left) (fill-box! right-box right))) (define (extent dc x y) (let* ([width-box (box 0)] [height-box (box 0)] [bottom-box (box 0)] [top-box (box 0)] [left-box (box 0)] [right-box (box 0)]) (super get-extent dc x y width-box height-box bottom-box top-box left-box right-box) (values (unbox width-box) (unbox height-box) (unbox bottom-box) (unbox top-box) (unbox left-box) (unbox right-box)))))) (define unreadable-snipclass (let* ([unreadable-snipclass (new (class snip-class% (super-new) (override read) (define (read stream) #f)))]) (send* unreadable-snipclass [set-classname "Unreadable"] [set-version 0]) unreadable-snipclass)) (define (fill-box! box/f value) (when box/f (set-box! box/f value))) )