moredialogs.rkt

#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)
                                  (when (send ok-button is-enabled?)
                                    (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))])]))