81 lines
2.4 KiB
Racket
81 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui/base racket/class)
|
|
|
|
(provide snip-canvas%)
|
|
|
|
(define snip-canvas%
|
|
(class editor-canvas%
|
|
(init parent
|
|
make-snip
|
|
[style null]
|
|
[label #f]
|
|
[horizontal-inset 5]
|
|
[vertical-inset 5]
|
|
[enabled #t]
|
|
[vert-margin 0]
|
|
[horiz-margin 0]
|
|
[min-width 0]
|
|
[min-height 0]
|
|
[stretchable-width #t]
|
|
[stretchable-height #t])
|
|
|
|
(define snip #f)
|
|
(define text (new read-only-text%))
|
|
(send text set-writable #f)
|
|
|
|
(define/public (get-snip) snip)
|
|
|
|
(define/override (on-size w h)
|
|
(update-snip w h)
|
|
(super on-size w h))
|
|
|
|
(define (update-snip w h)
|
|
(define snip-w (max 0 (- w (* 2 horizontal-inset))))
|
|
(define snip-h (max 0 (- h (* 2 vertical-inset))))
|
|
(cond [snip (send snip resize snip-w snip-h)]
|
|
[else (set-snip (make-snip snip-w snip-h))]))
|
|
|
|
(define (set-snip s)
|
|
(unless (is-a? s snip%)
|
|
(raise-type-error 'set-snip "snip%" s))
|
|
(set! snip s)
|
|
(send text set-writable #t)
|
|
(send text begin-edit-sequence #f)
|
|
(send text erase)
|
|
(send text insert snip)
|
|
(send text end-edit-sequence)
|
|
(send text set-writable #f))
|
|
|
|
(super-new [parent parent]
|
|
[editor text]
|
|
[horizontal-inset horizontal-inset]
|
|
[vertical-inset vertical-inset]
|
|
[label label]
|
|
[enabled enabled]
|
|
[style (list* 'no-hscroll 'no-vscroll style)]
|
|
[vert-margin vert-margin]
|
|
[horiz-margin horiz-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))
|
|
|
|
(define read-only-text%
|
|
(class text%
|
|
(define writable? #t)
|
|
(define/public (set-writable w?) (set! writable? w?))
|
|
|
|
(define/augment (can-change-style? start len) writable?)
|
|
(define/augment (can-delete? start len) writable?)
|
|
(define/augment (can-insert? start len) writable?)
|
|
(define/augment (can-load-file? filename format) writable?)
|
|
(define/augment (can-save-file? filename format) writable?)
|
|
(define/override (can-do-edit-operation? op [recursive? #t])
|
|
(case op
|
|
[(copy select-all) #t]
|
|
[else writable?]))
|
|
|
|
(super-new)
|
|
(send this hide-caret #t)))
|