(module snip-gui mzscheme
(require (lib "contract.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "mrpict.ss" "texpict")
(lib "etc.ss")
"snip-mixins.ss"
"interfaces.ss")
(provide/contract
[choice-snip% (class/c snip%)])
(define choice-snip%
(class (custom-snip-mixin snip%)
(super-new)
(init-field choices [choice 0])
(inherit get-admin get-location)
(public get-choice-index get-choice-text get-choices choose)
(override paint extent on-event)
(private show-popup-menu get-popup-menu)
(define (get-choice-index)
choice)
(define (get-choice-text)
(list-ref choices choice))
(define (get-choices)
choices)
(define (choose index)
(set! choice index)
(send (get-admin) resized #t))
(define (on-event dc x y ed-x ed-y event)
(if (and (send event button-changed? 'left)
(send event button-down? 'left))
(show-popup-menu)))
(define (show-popup-menu)
(let*-values ([(x y w h) (get-location #f)])
(send (send (send (get-admin) get-editor) get-admin)
popup-menu
(get-popup-menu)
x (+ y h))))
(define (get-popup-menu)
(let* ([menu (new popup-menu%)]
[choices (get-choices)])
(for-each
(lambda (index choice)
(new menu-item%
[label choice]
[parent menu]
[callback (lambda (i e) (choose index))]))
(build-list (length choices) identity)
choices)
menu))
(define (paint easel)
(send easel paint-pict 0 0 (text (get-choice-text))))
(define (extent dc x y)
(let*-values ([(width height descent ascent)
(send dc get-text-extent (get-choice-text))])
(values width height descent ascent 0 0)))))
)