(module moredialogs mzscheme
  (require (lib "class.ss")
	   (lib "class100.ss")
	   (lib "etc.ss")
	   (lib "list.ss")
	   (prefix wx: "kernel.ss")
	   "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 cancel (make-object button% "Cancel" p (lambda (b e) (done #f))))
      (define ok (make-object button% "OK" p (lambda (b e) (done #t)) '(border)))
      (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 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)
	  (make-object button% "Cancel" p (done #f))
	  (make-object button% "OK" p (done #t) '(border))
	  (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)
	  (make-object button% "Cancel" p (done #f))
	  (set! ok-button (make-object button% "OK" p (done #t) '(border)))
	  (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 (not (eq? (system-type) 'unix))
	  (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 (class100 canvas% ()
					  (override
					    [on-paint (lambda () (repaint #f #f))])
					  (sequence (super-init f))))]
		   [p (make-object vertical-pane% f)]
		   [repaint (lambda (s e)
			      (let ([c (make-object wx:color% 
						    (send red get-value)
						    (send green get-value)
						    (send blue get-value))])
				(wx:fill-private-color (send canvas get-dc) c)))]
		   [make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))]
		   [red (make-color-slider "Red:")]
		   [green (make-color-slider "Green:")]
		   [blue (make-color-slider "Blue:")]
		   [bp (make-object horizontal-pane% f)])
	    (when color
	      (send red set-value (send color red))
	      (send green set-value (send color green))
	      (send blue set-value (send color blue)))
	    (make-object button% "Cancel" bp (done #f))
	    (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?
		 (make-object wx:color% 
			      (send red get-value)
			      (send green get-value)
			      (send blue get-value)))))])))
