100 lines
3.8 KiB
Racket
100 lines
3.8 KiB
Racket
#lang racket/gui
|
|
(require framework
|
|
slideshow/pict
|
|
"display.rkt"
|
|
"constants.rkt"
|
|
"pict-canvas.rkt")
|
|
(provide label
|
|
mt-label
|
|
bold-label
|
|
mt-bold-label
|
|
section-header
|
|
(struct-out event-target)
|
|
make-listener-table
|
|
add-receiver
|
|
post-event)
|
|
|
|
(define bold-system-font
|
|
(send the-font-list find-or-create-font
|
|
(send normal-control-font get-point-size)
|
|
(send normal-control-font get-family)
|
|
(send normal-control-font get-style)
|
|
'bold))
|
|
|
|
(define (label p str)
|
|
(new message% [parent p]
|
|
[label str]
|
|
[stretchable-width #t]))
|
|
|
|
(define (mt-label p)
|
|
(label p ""))
|
|
|
|
(define (bold-label p str)
|
|
(new message% [parent p]
|
|
[label str]
|
|
[font bold-system-font]
|
|
[stretchable-width #t]))
|
|
|
|
(define (mt-bold-label p)
|
|
(bold-label p ""))
|
|
|
|
(define (section-header par name orientation)
|
|
(let* ([text-pict (colorize (text name) (header-forecolor))]
|
|
[text-container (pin-over (colorize (rectangle (+ 10 (pict-width text-pict))
|
|
(+ 10 (pict-height text-pict)))
|
|
(header-backcolor))
|
|
5
|
|
5
|
|
text-pict)]
|
|
[c (case orientation
|
|
[(horizontal)
|
|
(let ([canv (new pict-canvas%
|
|
[parent par]
|
|
[redraw-on-resize #t]
|
|
[pict-builder (λ (vregion)
|
|
(lc-superimpose (colorize (filled-rectangle (viewable-region-width vregion)
|
|
HEADER-HEIGHT)
|
|
(header-backcolor))
|
|
text-container))]
|
|
[min-height HEADER-HEIGHT]
|
|
[stretchable-width #t]
|
|
[stretchable-height #f])])
|
|
canv)]
|
|
[(vertical)
|
|
(let ([canv (new pict-canvas%
|
|
[parent par]
|
|
[redraw-on-resize #t]
|
|
[pict-builder (λ (vregion)
|
|
(rotate (lc-superimpose (colorize (filled-rectangle (viewable-region-height vregion)
|
|
HEADER-HEIGHT)
|
|
(header-backcolor))
|
|
text-container)
|
|
-1.57079633))]
|
|
[min-width HEADER-HEIGHT]
|
|
[stretchable-width #f]
|
|
[stretchable-height #t])])
|
|
canv)])])
|
|
c))
|
|
|
|
;Events
|
|
;receiver : any
|
|
;handler : (any -> void)
|
|
(struct event-target (receiver handler) #:transparent)
|
|
|
|
(define (make-listener-table) (make-hash))
|
|
|
|
(define (add-receiver table evt-name object handler)
|
|
(hash-update! table
|
|
evt-name
|
|
(λ (old)
|
|
(cons (event-target object handler) old))
|
|
(list (event-target object handler))))
|
|
|
|
(define (post-event table name sender arg)
|
|
(let ([targets (hash-ref table name)])
|
|
(for ([target (in-list targets)])
|
|
(let ([receiver (event-target-receiver target)]
|
|
[handler (event-target-handler target)])
|
|
(unless (eq? receiver sender)
|
|
(handler arg))))))
|