102 lines
2.7 KiB
Scheme
102 lines
2.7 KiB
Scheme
|
|
(module utils mzscheme
|
|
(require (prefix mred: mred)
|
|
mzlib/class
|
|
mzlib/etc
|
|
mzlib/list)
|
|
|
|
(define-syntax (private-field stx)
|
|
(syntax-case stx ()
|
|
[(_ (id val) ...)
|
|
(syntax/loc stx (begin (define id val) ...))]))
|
|
|
|
(define make-one-line/callback-edit
|
|
(opt-lambda (parent label cb [v ""])
|
|
(make-object mred:text-field% label parent
|
|
(lambda (t e) (cb (send t get-value))) v)))
|
|
|
|
(define make-number-control
|
|
(lambda (parent label value get-min get-max set-v)
|
|
(let* ([p (make-object mred:horizontal-panel% parent)]
|
|
[l (make-object mred:message% label p)]
|
|
[vl (make-object mred:message% "999999" p)]
|
|
[set-value
|
|
(lambda (n)
|
|
(set! value n)
|
|
(send vl set-label (number->string n))
|
|
(set-v n))]
|
|
[b (make-object mred:button%
|
|
"Set..."
|
|
p
|
|
(lambda (b e)
|
|
(let ([v (mred:get-text-from-user
|
|
(format "~a, in [~a, ~a]:" label (get-min) (get-max))
|
|
label
|
|
#f
|
|
(number->string value))])
|
|
(when v
|
|
(let ([n (string->number v)])
|
|
(if (and (integer? n) (exact? n)
|
|
(>= n (get-min)) (<= n (get-max)))
|
|
(set-value n)
|
|
(mred:message-box "Error" "Bad value")))))))])
|
|
(send vl set-label (number->string value))
|
|
(make-object (class object% ()
|
|
(public*
|
|
[get-val (lambda () value)]
|
|
[check (lambda ()
|
|
(when (< value (get-min))
|
|
(set-value (get-min)))
|
|
(when (> value (get-max))
|
|
(set-value (get-max))))])
|
|
(super-new))))))
|
|
|
|
(define new-name (lambda (base) (symbol->string (gensym base))))
|
|
|
|
(define (stream-write-list stream l)
|
|
(send stream put (length l))
|
|
(for-each
|
|
(lambda (i)
|
|
(send stream put (string->bytes/utf-8 i)))
|
|
l))
|
|
|
|
(define (get-bytes->string version)
|
|
(if (version . >= . 5)
|
|
bytes->string/utf-8
|
|
bytes->string/latin-1))
|
|
|
|
(define (stream-read-list stream version)
|
|
(let ([n (send stream get-exact)]
|
|
[b->s (get-bytes->string version)])
|
|
(let loop ([n n])
|
|
(if (zero? n)
|
|
null
|
|
(cons (b->s (send stream get-bytes)) (loop (sub1 n)))))))
|
|
|
|
(define cached-region #f)
|
|
(define cached-region-dc #f)
|
|
|
|
(define (with-clipping-region dc x y w h thunk)
|
|
(let ([r (send dc get-clipping-region)]
|
|
[r2 (if (eq? dc cached-region-dc)
|
|
cached-region
|
|
(make-object mred:region% dc))])
|
|
(set! cached-region-dc #f)
|
|
(send r2 set-rectangle x y w h)
|
|
(send r2 intersect r)
|
|
(send dc set-clipping-region r2)
|
|
(thunk)
|
|
(send dc set-clipping-region r)
|
|
(set! cached-region r2)
|
|
(set! cached-region-dc dc)))
|
|
|
|
(provide private-field
|
|
make-one-line/callback-edit
|
|
make-number-control
|
|
new-name
|
|
get-bytes->string
|
|
stream-write-list
|
|
stream-read-list
|
|
with-clipping-region))
|
|
|