156 lines
4.0 KiB
Racket
156 lines
4.0 KiB
Racket
|
|
(module canvas mzscheme
|
|
(require (prefix mred: mred)
|
|
mzlib/class
|
|
mzlib/file
|
|
mzlib/pretty
|
|
mzlib/etc
|
|
mzlib/list
|
|
"utils.ss"
|
|
"base.ss"
|
|
"feature.ss")
|
|
|
|
(define gb:make-canvas-hscroll-checkable-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #t
|
|
void void)
|
|
(inherit get-tagged-value)
|
|
(public*
|
|
[get-hscroll
|
|
(lambda () (get-tagged-value 'hscroll))])
|
|
(super-new))))
|
|
|
|
(define gb:make-canvas-vscroll-checkable-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-boolean-configure-snip% cl 'vscroll "Vertical Scroll" #t
|
|
void void)
|
|
(inherit get-tagged-value)
|
|
(public*
|
|
[get-vscroll
|
|
(lambda () (get-tagged-value 'vscroll))])
|
|
(super-new))))
|
|
|
|
(define gb:make-sb-box-snip%
|
|
(lambda (cl item-kind)
|
|
(class cl
|
|
(inherit-field w h)
|
|
(inherit get-hscroll get-vscroll)
|
|
(field
|
|
[sb-width 10]
|
|
[canvas-min-space 15])
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(override*
|
|
[get-kind (lambda () item-kind)])
|
|
(super-new)))]
|
|
[init-x-stretch? (lambda () #t)]
|
|
[init-y-stretch? (lambda () #t)]
|
|
[gb-get-min-size
|
|
(lambda (dc)
|
|
(values (+ sb-width canvas-min-space)
|
|
(+ sb-width canvas-min-space)))]
|
|
[draw
|
|
(lambda (dc x y . other)
|
|
(send dc draw-rectangle x y w h)
|
|
(when (get-vscroll)
|
|
(send dc draw-line
|
|
(+ x w (- sb-width)) y
|
|
(+ x w (- sb-width)) (+ y h -1)))
|
|
(when (get-hscroll)
|
|
(send dc draw-line
|
|
x (+ y h (- sb-width))
|
|
(+ x w -1) (+ y h (- sb-width)))))])
|
|
(super-new))))
|
|
|
|
(define gb:make-canvas-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit get-hscroll get-vscroll gb-get-instantiate-class-getter)
|
|
(override*
|
|
[gb-get-style
|
|
(lambda ()
|
|
(append
|
|
(super gb-get-style)
|
|
(cond
|
|
[(and (get-hscroll) (get-vscroll)) '(hscroll vscroll)]
|
|
[(get-hscroll) '(hscroll)]
|
|
[(get-vscroll) '(vscroll)]
|
|
[else null])))]
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "canvas"))]
|
|
|
|
[gb-get-default-class (lambda () 'canvas%)])
|
|
(super-new))))
|
|
|
|
(define gb:canvas-snip% (gb:make-canvas-snip%
|
|
(gb:make-sb-box-snip%
|
|
(gb:make-canvas-vscroll-checkable-snip%
|
|
(gb:make-canvas-hscroll-checkable-snip%
|
|
gb:atomic-snip%))
|
|
"Canvas")
|
|
"gb:canvas"))
|
|
|
|
(register-class gb:canvas-snip% "gb:canvas")
|
|
|
|
(define gb:make-ecanvas-hscroll-select-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-select-configure-snip% cl 'hscroll "Horizontal Scroll"
|
|
'("Show" "Hide" "No Scrolling"))
|
|
(inherit get-tagged-value)
|
|
(public*
|
|
[get-hscroll
|
|
(lambda () (zero? (get-hscroll-val)))]
|
|
[get-hscroll-val
|
|
(lambda () (get-tagged-value 'hscroll))])
|
|
(super-new))))
|
|
|
|
(define gb:make-ecanvas-vscroll-select-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-select-configure-snip% cl 'vscroll "Vertical Scroll"
|
|
'("Show" "Hide" "No Scrolling"))
|
|
(inherit get-tagged-value)
|
|
(public*
|
|
[get-vscroll
|
|
(lambda () (zero? (get-vscroll-val)))]
|
|
[get-vscroll-val
|
|
(lambda () (get-tagged-value 'vscroll))])
|
|
(super-new))))
|
|
|
|
(define gb:make-editor-canvas-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit get-hscroll-val get-vscroll-val)
|
|
(override*
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "ecanvas"))]
|
|
|
|
[gb-get-default-class (lambda () 'editor-canvas%)]
|
|
[gb-get-style
|
|
(lambda ()
|
|
(append
|
|
(super gb-get-style)
|
|
(case (get-hscroll-val)
|
|
[(0) null]
|
|
[(1) '(hide-hscroll)]
|
|
[(2) '(no-hscroll)])
|
|
(case (get-vscroll-val)
|
|
[(0) ()]
|
|
[(1) '(hide-vscroll)]
|
|
[(2) '(no-vscroll)])))])
|
|
(super-new))))
|
|
|
|
(define gb:editor-canvas-snip% (gb:make-editor-canvas-snip%
|
|
(gb:make-sb-box-snip%
|
|
(gb:make-ecanvas-vscroll-select-snip%
|
|
(gb:make-ecanvas-hscroll-select-snip%
|
|
gb:atomic-snip%))
|
|
"Editor Canvas")
|
|
"gb:editor-canvas"))
|
|
|
|
(register-class gb:editor-canvas-snip% "gb:editor-canvas")
|
|
|
|
(provide gb:canvas-snip%
|
|
gb:editor-canvas-snip%))
|