248 lines
7.6 KiB
Racket
248 lines
7.6 KiB
Racket
#| Rewrite these to use snip-wrapper% automatically |#
|
|
|
|
(module button-snip mzscheme
|
|
|
|
(require
|
|
mred
|
|
mzlib/class
|
|
mzlib/etc
|
|
"snip-wrapper.rkt")
|
|
|
|
(provide
|
|
text-button-snip%
|
|
button-snip%
|
|
toggle-button-snip%
|
|
embedded-button%
|
|
embedded-text-button%
|
|
embedded-toggle-button%)
|
|
|
|
(define embedded-button%
|
|
(class snip-wrapper%
|
|
(init images callback)
|
|
(super-new
|
|
(snip (new button-snip%
|
|
(images images)
|
|
(callback callback))))))
|
|
|
|
(define embedded-text-button%
|
|
(class snip-wrapper%
|
|
(init label callback)
|
|
(super-new
|
|
(snip (new text-button-snip%
|
|
(label label)
|
|
(callback callback))))))
|
|
|
|
(define embedded-toggle-button%
|
|
(class snip-wrapper%
|
|
(init images-off images-on turn-off turn-on (state 'on))
|
|
(field [btn (new toggle-button-snip%
|
|
(images-off images-off)
|
|
(images-on images-on)
|
|
(turn-off turn-off)
|
|
(turn-on turn-on)
|
|
(state state))])
|
|
;; Provide the original toggle-button-snip% interface
|
|
(define/public (set-state x) (send btn set-state x))
|
|
(super-new (snip btn))))
|
|
|
|
;; a snip of a button that can be pushed to invoke a given callback
|
|
(define button-snip%
|
|
(class image-snip%
|
|
(inherit load-file)
|
|
(init images)
|
|
(init-field callback)
|
|
(field
|
|
[got-click? false]
|
|
[inside? false]
|
|
[image (car images)]
|
|
[depressed (cdr images)])
|
|
|
|
;; (string? . -> . void?)
|
|
;; set the image to be displayed on the button when it is not clicked
|
|
(define/public (set-images i)
|
|
(set! image (car i))
|
|
(set! depressed (cdr i))
|
|
(load-file image))
|
|
|
|
;; Should I be calling super-on-event?
|
|
(define/override (on-event dc x y editorx editory event)
|
|
(case (send event get-event-type)
|
|
[(left-down)
|
|
(set! got-click? true)
|
|
(set! inside? true)
|
|
(load-file depressed)]
|
|
[(left-up)
|
|
(load-file image)
|
|
(when (and got-click? inside?)
|
|
(callback this event))
|
|
(set! got-click? false)
|
|
(set! inside? false)]
|
|
[(enter)
|
|
(set! inside? true)
|
|
(when got-click?
|
|
(load-file depressed))]
|
|
[(leave)
|
|
(set! inside? false)
|
|
(when got-click?
|
|
(load-file image))]
|
|
[else (void)]))
|
|
|
|
(super-new)
|
|
(load-file image)))
|
|
|
|
(define BUTTON-H-SPACE 5)
|
|
(define BUTTON-V-SPACE 2)
|
|
|
|
(define UNCLICKED-COLOR (make-object color% 220 220 175))
|
|
(define CLICKED-COLOR (make-object color% 100 100 50))
|
|
|
|
;; a textual button of the same type
|
|
(define text-button-snip%
|
|
(class string-snip%
|
|
(init label)
|
|
(init-field callback)
|
|
(field
|
|
[got-click? false]
|
|
[inside? false])
|
|
|
|
(define/private (inc b v)
|
|
(when b
|
|
(set-box! b (+ v (unbox b)))))
|
|
|
|
(define/override get-extent
|
|
(opt-lambda (dc x y [w #f] [h #f] [db #f] [dt #f] [dl #f] [dr #f])
|
|
(super get-extent dc (+ x BUTTON-H-SPACE) (+ y BUTTON-V-SPACE) w h db dt dl dr)
|
|
(inc w (* 2 BUTTON-H-SPACE))
|
|
(inc h (* 2 BUTTON-V-SPACE))
|
|
(inc db BUTTON-V-SPACE)
|
|
(inc dt BUTTON-V-SPACE)
|
|
(inc dl BUTTON-H-SPACE)
|
|
(inc dr BUTTON-H-SPACE)))
|
|
|
|
(define/override (draw dc x y t l r b dx dy caret)
|
|
(let ([p (send dc get-pen)]
|
|
[b (send dc get-brush)]
|
|
[smoothing (send dc get-smoothing)])
|
|
(send dc set-pen "black" 1 'solid)
|
|
(send dc set-brush
|
|
(if got-click? CLICKED-COLOR UNCLICKED-COLOR)
|
|
'solid)
|
|
(send dc set-smoothing 'aligned)
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(get-extent dc x y w h)
|
|
(send dc draw-rounded-rectangle x y (unbox w) (unbox h) BUTTON-H-SPACE))
|
|
(send dc set-pen p)
|
|
(send dc set-brush b)
|
|
(send dc set-smoothing smoothing))
|
|
(super draw dc (+ x BUTTON-H-SPACE) (+ y BUTTON-V-SPACE)
|
|
t l r b
|
|
(+ dx BUTTON-H-SPACE) (+ dy BUTTON-V-SPACE)
|
|
caret))
|
|
|
|
(define/override (on-event dc x y editorx editory event)
|
|
(case (send event get-event-type)
|
|
[(left-down)
|
|
(set! got-click? true)
|
|
(set! inside? true)
|
|
(refresh)]
|
|
[(left-up)
|
|
(when (and got-click? inside?)
|
|
(callback this event))
|
|
(set! got-click? false)
|
|
(set! inside? false)
|
|
(refresh)]
|
|
[(enter)
|
|
(set! inside? true)]
|
|
[(leave)
|
|
(set! inside? false)]
|
|
[else (void)]))
|
|
|
|
(inherit get-admin)
|
|
(define/private (refresh)
|
|
(let ([a (get-admin)])
|
|
(when a
|
|
(send a needs-update this 0 0 1000 100))))
|
|
|
|
(super-make-object label)
|
|
(inherit set-style)
|
|
(set-style control-style)))
|
|
|
|
;; a toggle button that displays different images
|
|
(define toggle-button-snip%
|
|
(class button-snip%
|
|
(inherit set-images)
|
|
(init-field images-off images-on turn-off turn-on (state 'on))
|
|
|
|
;; Emulates clicking the button to a certain state
|
|
(define/public (turn astate)
|
|
(case astate
|
|
[(off) (set-state 'off)
|
|
(turn-on this #f)]
|
|
[(on) (set-state 'on)
|
|
(turn-off this #f)]))
|
|
|
|
(define/public (set-state value)
|
|
(case value
|
|
[(off) (set-images images-off)
|
|
(set! state 'off)]
|
|
[(on) (set-images images-on)
|
|
(set! state 'on)]))
|
|
|
|
(super-new
|
|
(images (case state
|
|
[(on) images-on]
|
|
[(off) images-off]))
|
|
(callback
|
|
(lambda (b e)
|
|
;; NOTE: I lose the event right here, but turn can't require it.
|
|
;; Since it's public.
|
|
(case state
|
|
[(on) (turn 'off)]
|
|
[(off) (turn 'on)]))))))
|
|
|
|
;;;;;;;;;;
|
|
;; tests
|
|
#|
|
|
(require
|
|
mrlib/private/aligned-pasteboard/locked-pasteboard
|
|
mrlib/click-forwarding-editor)
|
|
|
|
(define (test)
|
|
(define f (new frame% (label "test") (width 200) (height 200)))
|
|
(define e (new (locked-pasteboard-mixin
|
|
(click-forwarding-editor-mixin pasteboard%))))
|
|
(define c (new editor-canvas% (editor e) (parent f)))
|
|
(define b (new button-snip%
|
|
(images (cons (build-path (collection-path "icons") "turn-up.gif")
|
|
(build-path (collection-path "icons") "turn-up-click.gif")))
|
|
(callback
|
|
(lambda (b e)
|
|
(message-box "Test" "Horray!")))))
|
|
(send e insert b)
|
|
(send f show #t))
|
|
|
|
(define (test2)
|
|
(define f (new frame% (label "test") (width 200) (height 200)))
|
|
(define e (new (locked-pasteboard-mixin
|
|
(click-forwarding-editor-mixin pasteboard%))))
|
|
(define c (new editor-canvas% (editor e) (parent f)))
|
|
(define t (new text%))
|
|
(define es (new editor-snip% (editor t)))
|
|
(define b (new toggle-button-snip%
|
|
(images-on (cons (build-path (collection-path "icons") "turn-up.gif")
|
|
(build-path (collection-path "icons") "turn-up-click.gif")))
|
|
(images-off (cons (build-path (collection-path "icons") "turn-down.gif")
|
|
(build-path (collection-path "icons") "turn-down-click.gif")))
|
|
(turn-on
|
|
(lambda (b e)
|
|
(send* t (erase) (insert "Up"))))
|
|
(turn-off
|
|
(lambda (b e)
|
|
(send* t (erase) (insert "Down"))))))
|
|
(send e insert es 50 0)
|
|
(send e insert b)
|
|
(send f show #t))
|
|
|#
|
|
)
|