397 lines
17 KiB
Racket
397 lines
17 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 (if (member 'alpha style)
|
|
in-color
|
|
(make-object wx:color%
|
|
(send in-color red)
|
|
(send in-color green)
|
|
(send in-color blue)
|
|
1.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))])]))
|