354 lines
9.3 KiB
Scheme
354 lines
9.3 KiB
Scheme
|
|
(module feature mzscheme
|
|
(require (prefix mred: mred)
|
|
mzlib/class
|
|
mzlib/file
|
|
mzlib/pretty
|
|
mzlib/etc
|
|
mzlib/list
|
|
"base.ss"
|
|
"utils.ss")
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mixins for GUI features
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define gb:make-text-label-snip%
|
|
(lambda (cl deflabel)
|
|
(class cl
|
|
(inherit get-style gb-need-recalc-size)
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(override*
|
|
[get-kind (lambda () deflabel)])
|
|
(super-new)
|
|
(private-field
|
|
[label-buffer (make-one-line/callback-edit controls "Label:"
|
|
(lambda (txt)
|
|
(set! label txt)
|
|
(gb-need-recalc-size))
|
|
label)])))]
|
|
[gb-instantiate-arguments
|
|
(lambda ()
|
|
`(,@(super gb-instantiate-arguments)
|
|
[label ,(get-label)]))])
|
|
(field
|
|
[label deflabel])
|
|
(public*
|
|
[get-label
|
|
(lambda ()
|
|
label)]
|
|
[get-label-size
|
|
(lambda (dc)
|
|
(let-values ([(w h d a) (send dc get-text-extent label
|
|
(send (get-style) get-font))])
|
|
(values w h)))]
|
|
[draw-label
|
|
(lambda (dc x y)
|
|
(send dc draw-text label x y))]
|
|
|
|
[label-install
|
|
(lambda (n)
|
|
(set! label n))])
|
|
(override*
|
|
[copy
|
|
(lambda ()
|
|
(let ([o (super copy)])
|
|
(send o label-install label)
|
|
o))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (string->bytes/utf-8 label)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(label-install ((get-bytes->string version) (send stream get-bytes))))])
|
|
(super-new))))
|
|
|
|
(define gb:make-callback-snip%
|
|
(lambda (cl)
|
|
(class cl
|
|
(inherit-field name)
|
|
(public*
|
|
[get-callback-kinds (lambda () (list "-callback"))]
|
|
[get-callback-code (lambda ()
|
|
(map (lambda (x) '(lambda (w e) (void))) (get-callback-kinds)))]
|
|
[get-callback-names
|
|
(lambda ()
|
|
(map
|
|
(lambda (ct)
|
|
(string->symbol (string-append name ct)))
|
|
(get-callback-kinds)))]
|
|
[gb-get-unified-callback
|
|
(lambda ()
|
|
`(lambda (b e) (,(car (get-callback-names)) b e)))])
|
|
(override*
|
|
[gb-instantiate-arguments
|
|
(lambda ()
|
|
`(,@(super gb-instantiate-arguments)
|
|
[callback ,(gb-get-unified-callback)]))]
|
|
[gb-aux-instantiate
|
|
(lambda (mode)
|
|
(append
|
|
(if (or (output-mode-as-class? mode)
|
|
(output-mode-no-free-vars? mode))
|
|
(map (lambda (n c)
|
|
(if (output-mode-as-class? mode)
|
|
`(public* [,n ,c])
|
|
`(define ,n ,c)))
|
|
(get-callback-names) (get-callback-code))
|
|
null)
|
|
(super gb-aux-instantiate mode)))])
|
|
(super-new))))
|
|
|
|
(define gb:make-text-labelled-snip%
|
|
(lambda (cl deflabel)
|
|
(class (gb:make-text-label-snip% cl deflabel)
|
|
(inherit-field w h)
|
|
(inherit get-label-size draw-label gb-need-recalc-size)
|
|
(private-field
|
|
[hmargin 2]
|
|
[vertical-label? (init-vertical-label?)])
|
|
(public*
|
|
[get-label-top-margin (lambda () 0)]
|
|
[init-vertical-label? (lambda () #f)]
|
|
|
|
[get-min-body-size
|
|
(lambda (dc)
|
|
(values 0 0))]
|
|
[draw-body
|
|
(lambda (dc x y w h)
|
|
(void))]
|
|
|
|
[labelpos-install
|
|
(lambda (vert?)
|
|
(set! vertical-label? vert?))])
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(super-new)
|
|
(private-field
|
|
[direction-radio
|
|
(make-object mred:radio-box% "Label Position:" '("Top" "Left")
|
|
controls
|
|
(lambda (r e)
|
|
(set! vertical-label? (zero? (send direction-radio get-selection)))
|
|
(gb-need-recalc-size))
|
|
'(horizontal))])
|
|
(send direction-radio set-selection (if vertical-label? 0 1))))]
|
|
[gb-get-min-size
|
|
(lambda (dc)
|
|
(let-values ([(x y) (get-label-size dc)]
|
|
[(x2 y2) (get-min-body-size dc)]
|
|
[(+x +y) (if vertical-label?
|
|
(values max +)
|
|
(values (lambda (a b) (+ a b hmargin)) max))])
|
|
(values (+x x x2) (+y (+ y (get-label-top-margin)) y2))))]
|
|
[draw
|
|
(lambda (dc x y . other)
|
|
(draw-label dc x (+ y (get-label-top-margin)))
|
|
(let*-values ([(lw lh) (get-label-size dc)]
|
|
[(dx dy) (if vertical-label?
|
|
(values 0 lh)
|
|
(values (+ lw hmargin) 0))])
|
|
(with-clipping-region dc (+ x dx) (+ y dy) (- w dx) (- h dy)
|
|
(lambda ()
|
|
(draw-body dc (+ x dx) (+ y dy) (- w dx) (- h dy))))))]
|
|
|
|
[gb-get-style
|
|
(lambda ()
|
|
(cons (if vertical-label?
|
|
'vertical-label
|
|
'horizontal-label)
|
|
(super gb-get-style)))]
|
|
|
|
[copy
|
|
(lambda ()
|
|
(let ([o (super copy)])
|
|
(send o labelpos-install vertical-label?)
|
|
o))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (if vertical-label? 1 0)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(labelpos-install (positive? (send stream get-exact))))])
|
|
(super-new))))
|
|
|
|
|
|
|
|
(define gb:make-layout-snip%
|
|
(lambda (cl)
|
|
(class cl
|
|
(inherit gb-need-recalc-size)
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(super-new)
|
|
(private-field
|
|
[layout-direction-radio
|
|
(make-object mred:radio-box%
|
|
"Layout:"
|
|
'("Vertical" "Horizontal")
|
|
controls
|
|
(lambda (r e)
|
|
(set! vertical-layout?
|
|
(zero? (send layout-direction-radio get-selection)))
|
|
(gb-need-recalc-size))
|
|
'(horizontal))])
|
|
(send layout-direction-radio set-selection (if vertical-layout? 0 1))))])
|
|
(field
|
|
[vertical-layout? (init-vertical-layout?)])
|
|
(public*
|
|
[init-vertical-layout? (lambda () #t)]
|
|
[layout-install
|
|
(lambda (vert?)
|
|
(set! vertical-layout? vert?))])
|
|
(override*
|
|
[gb-get-style
|
|
(lambda ()
|
|
(cons (if vertical-layout?
|
|
'vertical
|
|
'horizontal)
|
|
(super gb-get-style)))]
|
|
[copy
|
|
(lambda ()
|
|
(let ([o (super copy)])
|
|
(send o layout-install vertical-layout?)
|
|
o))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (if vertical-layout? 1 0)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(layout-install (positive? (send stream get-exact))))])
|
|
(super-new))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mixins for configuration options
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define gb:make-configure-snip%
|
|
(lambda (cl tag init)
|
|
(class cl
|
|
(private-field
|
|
[v init])
|
|
(override*
|
|
[get-tagged-value
|
|
(lambda (t)
|
|
(if (eq? t tag)
|
|
v
|
|
(super get-tagged-value t)))]
|
|
[set-tagged-value
|
|
(lambda (t v-in)
|
|
(if (eq? t tag)
|
|
(set! v v-in)
|
|
(super set-tagged-value t v-in)))]
|
|
|
|
[copy
|
|
(lambda ()
|
|
(let ([o (super copy)])
|
|
(send o set-tagged-value tag v)
|
|
o))])
|
|
(super-new))))
|
|
|
|
(define gb:make-boolean-configure-snip%
|
|
(lambda (cl tag label init change-cb init-cb)
|
|
(class (gb:make-configure-snip% cl tag init)
|
|
(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(define this-snip this)
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(override*
|
|
[find-control
|
|
(lambda (t)
|
|
(if (eq? t tag)
|
|
c
|
|
(super find-control t)))])
|
|
(super-new)
|
|
(private-field
|
|
[c (make-object mred:check-box%
|
|
label controls
|
|
(lambda (c e)
|
|
(set-tagged-value tag (send c get-value))
|
|
(change-cb this this-snip)
|
|
(gb-need-recalc-size)))])
|
|
(send c set-value (get-tagged-value tag))
|
|
(init-cb this this-snip)))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (if (get-tagged-value tag) 1 0)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(set-tagged-value tag (positive? (send stream get-exact))))])
|
|
(super-new))))
|
|
|
|
(define gb:make-multi-checkable-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-boolean-configure-snip% cl 'multi "Multiple Lines" #f
|
|
(lambda (f snip)
|
|
(send snip multi-changed f))
|
|
void)
|
|
(inherit get-tagged-value)
|
|
(public*
|
|
[get-multi
|
|
(lambda () (get-tagged-value 'multi))]
|
|
[multi-changed
|
|
(lambda (f)
|
|
(send (send f find-control 'hscroll) enable (get-multi)))])
|
|
(super-new))))
|
|
|
|
(define gb:make-select-configure-snip%
|
|
(lambda (cl tag label choices)
|
|
(class (gb:make-configure-snip% cl tag 0)
|
|
(inherit gb-need-recalc-size get-tagged-value set-tagged-value)
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(super-new)
|
|
(private-field
|
|
[c (make-object mred:choice%
|
|
label choices controls
|
|
(lambda (c e)
|
|
(set-tagged-value tag (send c get-selection))
|
|
(gb-need-recalc-size)))])
|
|
(send c set-selection (get-tagged-value tag))))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (get-tagged-value tag)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(set-tagged-value tag (send stream get-exact)))])
|
|
(super-new))))
|
|
|
|
(provide gb:make-text-label-snip%
|
|
gb:make-callback-snip%
|
|
gb:make-text-labelled-snip%
|
|
gb:make-layout-snip%
|
|
|
|
gb:make-configure-snip%
|
|
gb:make-boolean-configure-snip%
|
|
gb:make-multi-checkable-snip%
|
|
gb:make-select-configure-snip%))
|