5f63b8c95b
Closes PR 15121 A better solution would be to implement the dialog, but given how long it's been broken, maybe no one cares enough for that to be worthwhile.
400 lines
18 KiB
Racket
400 lines
18 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: racket/snip/private/style)
|
|
"lock.rkt"
|
|
"const.rkt"
|
|
"check.rkt"
|
|
"wx.rkt"
|
|
"helper.rkt"
|
|
"mrtop.rkt"
|
|
"mrcanvas.rkt"
|
|
"mritem.rkt"
|
|
"mrpanel.rkt"
|
|
"mrtextfield.rkt")
|
|
|
|
(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 title message
|
|
[parent #f]
|
|
[init-val ""]
|
|
[style null]
|
|
#:dialog-mixin [dialog-mixin values]
|
|
#:validate [validate (λ (x) #t)])
|
|
(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 disallow-invalid) style)
|
|
(define f (make-object (dialog-mixin dialog%) title parent box-width))
|
|
(define ok? #f)
|
|
(define (done ?) (set! ok? ?) (send f show #f))
|
|
(define t (new text-field%
|
|
[label message]
|
|
[parent f]
|
|
[callback (λ (t e)
|
|
(cond
|
|
[(eq? (send e get-event-type) 'text-field-enter)
|
|
(done #t)]
|
|
[else (do-validation)]))]
|
|
[init-value init-val]
|
|
[style (list* 'single 'vertical-label
|
|
(if (memq 'password style)
|
|
'(password)
|
|
'()))]))
|
|
(define default-background (send t get-field-background))
|
|
(define (do-validation)
|
|
(define valid? (validate (send t get-value)))
|
|
(send t set-field-background
|
|
(if valid?
|
|
default-background
|
|
(send wx:the-color-database find-color "pink")))
|
|
(when (memq 'disallow-invalid style)
|
|
(send ok-button enable valid?)))
|
|
(define p (make-object horizontal-pane% f))
|
|
(send p set-alignment 'right 'center)
|
|
(send f stretchable-height #f)
|
|
(define-values (ok-button cancel-button)
|
|
(ok-cancel
|
|
(lambda () (make-object button% "OK" p (λ (b e) (done #t)) '(border)))
|
|
(lambda () (make-object button% "Cancel" p (λ (b e) (done #f))))))
|
|
(send (send t get-editor) select-all)
|
|
(send t focus)
|
|
(send f center)
|
|
(do-validation)
|
|
(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-argument-error 'get-choices-from-user "(listof label-string?)" choices))
|
|
(check-top-level-parent/false 'get-choices-from-user parent)
|
|
(unless (and (list? init-vals) (andmap exact-nonnegative-integer? init-vals))
|
|
(raise-argument-error 'get-choices-from-user "(listof exact-nonnegative-integer?)" init-vals))
|
|
(check-style 'get-choices-from-user '(single multiple extended) null style)
|
|
(when (and (memq 'single style) (> (length init-vals) 1))
|
|
(raise-arguments-error 'get-choices-from-user
|
|
"multiple initial-selection indices provided with 'single style"
|
|
"indices" 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-arguments-error
|
|
'get-choices-from-user
|
|
"out of range;\n inital-selection list specifies an out-of-range index"
|
|
"index" i
|
|
"provided choices" (send l get-number)
|
|
"list..." init-vals))
|
|
(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 in-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 in-color)
|
|
(check-style 'get-color-from-user #f '(alpha) style)
|
|
(cond
|
|
[(eq? (wx:color-from-user-platform-mode) 'dialog)
|
|
(wx:get-color-from-user message (and parent (mred->wx parent)) in-color)]
|
|
[else
|
|
(define color (cond
|
|
[in-color
|
|
(if (member 'alpha style)
|
|
in-color
|
|
(make-object wx:color%
|
|
(send in-color red)
|
|
(send in-color green)
|
|
(send in-color blue)
|
|
1.0))]
|
|
[else (make-object wx:color% 0 0 0)]))
|
|
(define ok? #f)
|
|
(define f (make-object dialog% "Choose Color" parent))
|
|
(define (done ok) (lambda (b e) (set! ok? ok) (send f show #f)))
|
|
(define canvas (make-object (class canvas%
|
|
(define/override (on-paint)
|
|
(repaint void))
|
|
(super-new [parent f]))))
|
|
(define platform-p (and (string? (wx:color-from-user-platform-mode))
|
|
(new horizontal-panel%
|
|
[parent f]
|
|
[alignment '(right center)])))
|
|
(define p (make-object vertical-pane% f))
|
|
(define (repaint ext)
|
|
(let ([c (get-current-color)])
|
|
(ext c)
|
|
(wx:fill-private-color (send canvas get-dc) c)))
|
|
(define (update-and-repaint s e)
|
|
(repaint
|
|
(lambda (c)
|
|
(when platform-p
|
|
(wx:get-color-from-user c)))))
|
|
(define (make-color-slider l) (make-object slider% l 0 255 p update-and-repaint))
|
|
(define red (make-color-slider "Red:"))
|
|
(define green (make-color-slider "Green:"))
|
|
(define blue (make-color-slider "Blue:"))
|
|
(define alpha (and (member 'alpha style)
|
|
(new text-field%
|
|
[parent p]
|
|
[label "Alpha:"]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(update-ok-button-and-background))])))
|
|
(define (update-ok-button-and-background)
|
|
(when alpha
|
|
(define n (string->number (send alpha get-value)))
|
|
(define ok? (and n (real? n) (<= 0 n 1)))
|
|
(send ok-button enable ok?)
|
|
(send alpha set-field-background
|
|
(send wx:the-color-database find-color
|
|
(if ok? "white" "pink")))))
|
|
(define bp (make-object horizontal-pane% f))
|
|
(define (get-current-color)
|
|
(make-object wx:color%
|
|
(send red get-value)
|
|
(send green get-value)
|
|
(send blue get-value)
|
|
(if alpha
|
|
(string->number (send alpha get-value))
|
|
1.0)))
|
|
(define (install-color color)
|
|
(send red set-value (send color red))
|
|
(send green set-value (send color green))
|
|
(send blue set-value (send color blue))
|
|
(when alpha (send alpha set-value (format "~a" (send color alpha))))
|
|
(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))
|
|
(define-values (ok-button cancel-button)
|
|
(ok-cancel
|
|
(lambda ()
|
|
(make-object button% "OK" bp (done #t) '(border)))
|
|
(lambda ()
|
|
(make-object button% "Cancel" bp (done #f)))))
|
|
(send ok-button focus)
|
|
(update-ok-button-and-background)
|
|
(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))])]))
|