351 lines
15 KiB
Racket
351 lines
15 KiB
Racket
(module moredialogs mzscheme
|
|
(require mzlib/class
|
|
mzlib/etc
|
|
mzlib/list
|
|
(prefix wx: "kernel.ss")
|
|
(prefix wx: racket/snip)
|
|
"lock.ss"
|
|
"const.ss"
|
|
"check.ss"
|
|
"wx.ss"
|
|
"helper.ss"
|
|
"editor.ss"
|
|
"mrtop.ss"
|
|
"mrcanvas.ss"
|
|
"mrpopup.ss"
|
|
"mrmenu.ss"
|
|
"mritem.ss"
|
|
"mrpanel.ss"
|
|
"mrtextfield.ss")
|
|
|
|
(provide get-ps-setup-from-user
|
|
get-page-setup-from-user
|
|
can-get-page-setup-from-user?
|
|
get-text-from-user
|
|
get-choices-from-user
|
|
get-color-from-user)
|
|
|
|
(define (number->string* n)
|
|
(let ([s (number->string n)])
|
|
(regexp-replace #rx"[.]([0-9][0-9][0-9])[0-9]*$"
|
|
s
|
|
".\\1")))
|
|
|
|
(define get-ps-setup-from-user
|
|
(case-lambda
|
|
[() (get-ps-setup-from-user #f #f #f null)]
|
|
[(message) (get-ps-setup-from-user message #f #f null)]
|
|
[(message parent) (get-ps-setup-from-user message parent #f null)]
|
|
[(message parent pss) (get-ps-setup-from-user message parent pss null)]
|
|
[(message parent pss-in style)
|
|
(define _
|
|
(begin
|
|
;; Calls from C++ have wrong kind of window:
|
|
(when (is-a? parent wx:window%)
|
|
(set! parent (as-entry (lambda () (wx->mred parent)))))
|
|
|
|
(check-label-string/false 'get-ps-setup-from-user message)
|
|
(check-top-level-parent/false 'get-ps-setup-from-user parent)
|
|
(check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
|
|
(check-style 'get-ps-setup-from-user #f null style)))
|
|
|
|
(define bad-fields null)
|
|
(define number-callback
|
|
(lambda (f ev)
|
|
(let ([e (send f get-editor)]
|
|
[ok? (real? (string->number (send f get-value)))])
|
|
(send e change-style
|
|
(send (make-object wx:style-delta%)
|
|
set-delta-background
|
|
(if ok? "white" "yellow"))
|
|
0 (send e last-position))
|
|
(set! bad-fields (remq f bad-fields))
|
|
(unless ok?
|
|
(set! bad-fields (cons f bad-fields)))
|
|
(send ok enable (null? bad-fields)))))
|
|
|
|
(define pss (or pss-in (wx:current-ps-setup)))
|
|
(define f (make-object dialog% "PostScript Setup" parent))
|
|
(define papers
|
|
'("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in"))
|
|
(define p (make-object horizontal-pane% f))
|
|
(define paper (make-object choice% #f papers p void))
|
|
(define _0 (make-object vertical-pane% p))
|
|
(define-values (ok cancel)
|
|
(ok-cancel
|
|
(lambda () (make-object button% "OK" p (lambda (b e) (done #t)) '(border)))
|
|
(lambda () (make-object button% "Cancel" p (lambda (b e) (done #f))))))
|
|
(define unix? (eq? (system-type) 'unix))
|
|
(define dp (make-object horizontal-pane% f))
|
|
(define orientation (make-object radio-box% "Orientation:" '("Portrait" "Landscape") dp void))
|
|
(define destination (and unix? (make-object radio-box% "Destination:"
|
|
'("Printer" "Preview" "File") dp void)))
|
|
(define ssp (make-object horizontal-pane% f))
|
|
(define sp (make-object vertical-pane% ssp))
|
|
(define def-scale "0100.000")
|
|
(define def-offset "0000.000")
|
|
(define def-margin "0016.000")
|
|
(define xscale (make-object text-field% "Horizontal Scale:" sp number-callback def-scale))
|
|
(define xoffset (make-object text-field% "Horizontal Translation:" sp number-callback def-offset))
|
|
(define xmargin (make-object text-field% "Horizontal Margin:" sp number-callback def-margin))
|
|
(define sp2 (make-object vertical-pane% ssp))
|
|
(define yscale (make-object text-field% "Vertical Scale:" sp2 number-callback def-scale))
|
|
(define yoffset (make-object text-field% "Vertical Translation:" sp2 number-callback def-offset))
|
|
(define ymargin (make-object text-field% "Vertical Margin:" sp2 number-callback def-margin))
|
|
|
|
(define l2 (make-object check-box% "PostScript Level 2" f void))
|
|
|
|
(define cp (and unix? (make-object horizontal-pane% f)))
|
|
(define command (and unix? (make-object text-field% "Print Command:" cp void)))
|
|
(define vcommand (and unix? (make-object text-field% "Preview Command:" f void)))
|
|
|
|
(define ok? #f)
|
|
(define (done ?)
|
|
(send f show #f)
|
|
(set! ok? ?))
|
|
|
|
(define-values (xsb ysb xtb ytb xmb ymb)
|
|
(values (box 0) (box 0) (box 0) (box 0) (box 0) (box 0)))
|
|
|
|
(send paper set-selection (or (find-pos papers (send pss get-paper-name) equal?) 0))
|
|
(send orientation set-selection (if (eq? (send pss get-orientation) 'landscape) 1 0))
|
|
(when unix?
|
|
(send destination set-selection (case (send pss get-mode)
|
|
[(printer) 0] [(preview) 1] [(file) 2]))
|
|
(send command set-value (send pss get-command))
|
|
(send vcommand set-value (send pss get-preview-command)))
|
|
|
|
(send sp set-alignment 'right 'top)
|
|
(send sp2 set-alignment 'right 'top)
|
|
(send pss get-scaling xsb ysb)
|
|
(send xscale set-value (number->string* (unbox xsb)))
|
|
(send yscale set-value (number->string* (unbox ysb)))
|
|
(send pss get-translation xtb ytb)
|
|
(send xoffset set-value (number->string* (unbox xtb)))
|
|
(send yoffset set-value (number->string* (unbox ytb)))
|
|
(send pss get-margin xmb ymb)
|
|
(send xmargin set-value (number->string* (unbox xmb)))
|
|
(send ymargin set-value (number->string* (unbox ymb)))
|
|
(send xscale stretchable-width #f)
|
|
(send yscale stretchable-width #f)
|
|
(send xoffset stretchable-width #f)
|
|
(send yoffset stretchable-width #f)
|
|
(send xmargin stretchable-width #f)
|
|
(send ymargin stretchable-width #f)
|
|
|
|
(send l2 set-value (send pss get-level-2))
|
|
|
|
(send f set-alignment 'center 'top)
|
|
|
|
(map no-stretch (list f xscale yscale xoffset yoffset xmargin ymargin dp))
|
|
|
|
(send f center)
|
|
|
|
(send f show #t)
|
|
|
|
(if ok?
|
|
(let ([s (make-object wx:ps-setup%)]
|
|
[gv (lambda (c b)
|
|
(or (string->number (send c get-value)) (unbox b)))])
|
|
(send s set-paper-name (send paper get-string-selection))
|
|
(send s set-orientation (if (positive? (send orientation get-selection))
|
|
'landscape
|
|
'portrait))
|
|
(when unix?
|
|
(send s set-mode (case (send destination get-selection)
|
|
[(0) 'printer]
|
|
[(1) 'preview]
|
|
[(2) 'file])))
|
|
(send s set-scaling (gv xscale xsb) (gv yscale ysb))
|
|
(send s set-translation (gv xoffset xtb) (gv yoffset ytb))
|
|
(send s set-margin (gv xmargin xmb) (gv ymargin ymb))
|
|
(send s set-level-2 (send l2 get-value))
|
|
|
|
(when (eq? (system-type) 'unix)
|
|
(send s set-command (send command get-value))
|
|
(send s set-preview-command (send vcommand get-value)))
|
|
|
|
s)
|
|
#f)]))
|
|
|
|
(define get-page-setup-from-user
|
|
(case-lambda
|
|
[() (get-page-setup-from-user #f #f #f null)]
|
|
[(message) (get-page-setup-from-user message #f #f null)]
|
|
[(message parent) (get-page-setup-from-user message parent #f null)]
|
|
[(message parent pss) (get-page-setup-from-user message parent pss null)]
|
|
[(message parent pss-in style)
|
|
(check-label-string/false 'get-page-setup-from-user message)
|
|
(check-top-level-parent/false 'get-page-setup-from-user parent)
|
|
(check-instance 'get-page-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
|
|
(check-style 'get-page-setup-from-user #f null style)
|
|
|
|
(and (wx:can-show-print-setup?)
|
|
(let ([s (make-object wx:ps-setup%)])
|
|
(send s copy-from (or pss-in (wx:current-ps-setup)))
|
|
(and (parameterize ([wx:current-ps-setup s])
|
|
(wx:show-print-setup (and parent (mred->wx parent))))
|
|
s)))]))
|
|
|
|
(define (can-get-page-setup-from-user?)
|
|
(wx:can-show-print-setup?))
|
|
|
|
(define get-text-from-user
|
|
(case-lambda
|
|
[(title message) (get-text-from-user title message #f "" null)]
|
|
[(title message parent) (get-text-from-user title message parent "" null)]
|
|
[(title message parent init-val) (get-text-from-user title message parent init-val null)]
|
|
[(title message parent init-val style)
|
|
(check-label-string 'get-text-from-user title)
|
|
(check-label-string/false 'get-text-from-user message)
|
|
(check-top-level-parent/false 'get-text-from-user parent)
|
|
(check-string 'get-text-from-user init-val)
|
|
(check-style 'get-text-from-user #f '(password) style)
|
|
(let* ([f (make-object dialog% title parent box-width)]
|
|
[ok? #f]
|
|
[done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))])
|
|
(let ([t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter)
|
|
((done #t) #f #f)))
|
|
init-val (list* 'single 'vertical-label style))]
|
|
[p (make-object horizontal-pane% f)])
|
|
(send p set-alignment 'right 'center)
|
|
(send f stretchable-height #f)
|
|
(ok-cancel
|
|
(lambda () (make-object button% "OK" p (done #t) '(border)))
|
|
(lambda () (make-object button% "Cancel" p (done #f))))
|
|
(send (send t get-editor) select-all)
|
|
(send t focus)
|
|
(send f center)
|
|
(send f show #t)
|
|
(and ok? (send t get-value))))]))
|
|
|
|
(define get-choices-from-user
|
|
(case-lambda
|
|
[(title message choices) (get-choices-from-user title message choices #f null '(single))]
|
|
[(title message choices parent) (get-choices-from-user title message choices parent null '(single))]
|
|
[(title message choices parent init-vals) (get-choices-from-user title message choices parent init-vals '(single))]
|
|
[(title message choices parent init-vals style)
|
|
(check-label-string 'get-choices-from-user title)
|
|
(check-label-string/false 'get-choices-from-user message)
|
|
(unless (and (list? choices) (andmap label-string? choices))
|
|
(raise-type-error 'get-choices-from-user "list of strings (up to 200 characters)" choices))
|
|
(check-top-level-parent/false 'get-choices-from-user parent)
|
|
(unless (and (list? init-vals) (andmap (lambda (x) (and (integer? x) (exact? x) (not (negative? x)))) init-vals))
|
|
(raise-type-error 'get-choices-from-user "list of exact non-negative integers" init-vals))
|
|
(check-style 'get-choices-from-user '(single multiple extended) null style)
|
|
(when (and (memq 'single style) (> (length init-vals) 1))
|
|
(raise-mismatch-error 'get-choices-from-user
|
|
(format "multiple initial-selection indices provided with ~e style: " 'single)
|
|
init-vals))
|
|
(let* ([f (make-object dialog% title parent box-width (min 300 (max 150 (* 14 (length choices)))))]
|
|
[ok-button #f]
|
|
[update-ok (lambda (l) (send ok-button enable (not (null? (send l get-selections)))))]
|
|
[ok? #f]
|
|
[done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))])
|
|
(let ([l (make-object list-box% message choices f
|
|
(lambda (l e)
|
|
(update-ok l)
|
|
(when (eq? (send e get-event-type) 'list-box-dclick)
|
|
((done #t) #f #f)))
|
|
(cons 'vertical-label style))]
|
|
[p (make-object horizontal-pane% f)])
|
|
(for-each (lambda (i)
|
|
(when (>= i (send l get-number))
|
|
(raise-mismatch-error
|
|
'get-choices-from-user
|
|
(format "inital-selection list specifies an out-of-range index (~e choices provided): "
|
|
(send l get-number))
|
|
i))
|
|
(send l select i #t)) init-vals)
|
|
(send p set-alignment 'right 'center)
|
|
(send p stretchable-height #f)
|
|
(ok-cancel (lambda ()
|
|
(set! ok-button (make-object button% "OK" p (done #t) '(border))))
|
|
(lambda ()
|
|
(make-object button% "Cancel" p (done #f))))
|
|
(update-ok l)
|
|
(send f center)
|
|
(when (and (pair? init-vals)
|
|
((car init-vals) . > . 1))
|
|
;; Make sure initial selection is visible:
|
|
(send f reflow-container)
|
|
(send l set-first-visible-item (sub1 (car init-vals))))
|
|
(send f show #t)
|
|
(and ok? (send l get-selections))))]))
|
|
|
|
(define get-color-from-user
|
|
(case-lambda
|
|
[() (get-color-from-user #f #f #f null)]
|
|
[(message) (get-color-from-user message #f #f null)]
|
|
[(message parent) (get-color-from-user message parent #f null)]
|
|
[(message parent color) (get-color-from-user message parent color null)]
|
|
[(message parent color style)
|
|
(check-label-string/false 'get-color-from-user message)
|
|
(check-top-level-parent/false 'get-color-from-user parent)
|
|
(check-instance 'get-color-from-user wx:color% 'color% #t color)
|
|
(check-style 'get-color-from-user #f null style)
|
|
(if (eq? (wx:color-from-user-platform-mode) 'dialog)
|
|
(wx:get-color-from-user message (and parent (mred->wx parent)) color)
|
|
(letrec ([ok? #f]
|
|
[f (make-object dialog% "Choose Color" parent)]
|
|
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
|
|
[canvas (make-object (class canvas%
|
|
(define/override (on-paint)
|
|
(repaint void))
|
|
(super-new [parent f])))]
|
|
[platform-p (and (string? (wx:color-from-user-platform-mode))
|
|
(new horizontal-panel%
|
|
[parent f]
|
|
[alignment '(right center)]))]
|
|
[p (make-object vertical-pane% f)]
|
|
[repaint (lambda (ext)
|
|
(let ([c (get-current-color)])
|
|
(ext c)
|
|
(wx:fill-private-color (send canvas get-dc) c)))]
|
|
[update-and-repaint (lambda (s e)
|
|
(repaint
|
|
(lambda (c)
|
|
(when platform-p
|
|
(wx:get-color-from-user c)))))]
|
|
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))]
|
|
[red (make-color-slider "Red:")]
|
|
[green (make-color-slider "Green:")]
|
|
[blue (make-color-slider "Blue:")]
|
|
[bp (make-object horizontal-pane% f)]
|
|
[get-current-color
|
|
(lambda ()
|
|
(make-object wx:color%
|
|
(send red get-value)
|
|
(send green get-value)
|
|
(send blue get-value)))]
|
|
[install-color
|
|
(lambda (color)
|
|
(send red set-value (send color red))
|
|
(send green set-value (send color green))
|
|
(send blue set-value (send color blue))
|
|
(send canvas refresh))])
|
|
(when platform-p
|
|
(new button%
|
|
[parent platform-p]
|
|
[label (wx:color-from-user-platform-mode)]
|
|
[callback (lambda (b e) (wx:get-color-from-user 'show))])
|
|
(wx:get-color-from-user (or color
|
|
(make-object wx:color% 0 0 0)))
|
|
(send (mred->wx f) set-color-callback (lambda ()
|
|
(install-color
|
|
(wx:get-color-from-user 'get)))))
|
|
(when color (install-color color))
|
|
(ok-cancel
|
|
(lambda ()
|
|
(make-object button% "Cancel" bp (done #f)))
|
|
(lambda ()
|
|
(send (make-object button% "OK" bp (done #t) '(border)) focus)))
|
|
(send bp set-alignment 'right 'center)
|
|
(send p set-alignment 'right 'center)
|
|
(send p stretchable-height #f)
|
|
(send canvas min-height 50)
|
|
(send f center)
|
|
(send f show #t)
|
|
(and ok?
|
|
(get-current-color))))])))
|