(module wxlitem mzscheme
  (require mzlib/class
	   mzlib/class100
           mzlib/file
           (only racket/base remq)
           racket/snip/private/prefs
	   (prefix wx: "kernel.ss")
	   "lock.ss"
	   "helper.ss"
	   "const.ss"
	   "wx.ss"
	   "check.ss"
	   "wxwindow.ss"
	   "wxitem.ss"
           "wxpanel.ss")

  (provide (protect wx-choice%
                    wx-list-box%
                    wx-radio-box%
                    wx-gauge%
                    wx-slider%))

  ;; ----------------------------------------

  (define (is-horiz? style parent)
    (cond
     [(memq 'vertical-label style) #f]
     [(memq 'horizontal-label style) #t]
     [else (eq? (send (send parent get-window) get-label-position) 'horizontal)]))

  (define (make-sub horiz? proxy this ha va)
    (if horiz?
        (begin
          (send this alignment ha va)
          this)
        (let ([p (make-object wx-vertical-pane% #f proxy this null #f)])
          (send p skip-subwindow-events? #t)
          (send (send p area-parent) add-child p)
          (send p alignment ha va)
          p)))

  (define (make-label label proxy p font)
    (and label 
         (let ([l (make-object wx-message% #f proxy p label -1 -1 null font)])
           (send l skip-subwindow-events? #t)
           l)))

  (define (filter-style style)
    (remq 'deleted style))

  (define-syntax-rule (bounce c (m . args) ...)
    (begin
      (define/public m (lambda args (send c m . args)))
      ...))

  ;; ----------------------------------------
  
  (define wx-label-panel%
    (class wx-control-horizontal-panel% 
      (init proxy parent label style font halign valign)
      (inherit area-parent)
      (define c #f)

      (define/override (enable on?) (if c (send c enable on?) (void)))
      (define/override (is-enabled?) (if c (send c is-enabled?) #t))
      (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))

      (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
      (unless (memq 'deleted style)
        (send (area-parent) add-child this))
      (define horiz? (is-horiz? style parent))
      (define p (make-sub horiz? proxy this (if horiz? 'left halign) valign))

      (define l (make-label label proxy p font))
      (define/public (set-label s) (when l (send l set-label s)))
      (define/public (get-label) (and l (send l get-label)))

      (define/public (get-p) p)
      (define/public (set-c v sx? sy?) 
        (set! c v)
        (send c stretchable-in-x sx?)
        (send c stretchable-in-y sy?)
        (send c skip-subwindow-events? #t))))

  ;; ----------------------------------------

  (define wx-internal-choice% 
    (class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font)
      (override 
        [handles-key-code 
         (lambda (x alpha? meta?) 
           (or (memq x '(up down))
               (and alpha? (not meta?))))])
      (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))

  (define wx-choice%
    (class wx-label-panel% 
      (init mred proxy parent cb label x y w h choices style font)
      (inherit stretchable-in-y stretchable-in-x get-p set-c)

      (super-init proxy parent label style font 'left 'center)

      (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices 
                             (filter-style style) font))
      (set-c c #t #f)

      (bounce 
       c
       (set-selection i)
       (get-selection)
       (number)
       (clear)
       (append lbl))

      (stretchable-in-y #f)
      (stretchable-in-x #f)))

  ;; ----------------------------------------

  (define list-box-wheel-step #f)

  (define wx-internal-list-box%
    (make-window-glue% 
     (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font 
                                                              label-font columns column-order)
       (inherit get-first-item
		set-first-visible-item)
       (private
	 [scroll (lambda (dir)
		   (unless list-box-wheel-step
		     (set! list-box-wheel-step (get-preference* '|GRacket:wheelStep| (lambda () 3)))
		     (unless (and (number? list-box-wheel-step)
				  (exact? list-box-wheel-step)
				  (integer? list-box-wheel-step)
				  (<= 1 list-box-wheel-step 100))
		       (set! list-box-wheel-step 3)))
		   (let ([top (get-first-item)])
		     (set-first-visible-item
                      (max 0 (+ top (* list-box-wheel-step dir))))))])
       (override
	 [handles-key-code (lambda (x alpha? meta?)
			     (case x
			       [(up down) #t]
			       [else (and alpha? (not meta?))]))]
	 [pre-on-char (lambda (w e)
			(or (super pre-on-char w e)
			    (case (send e get-key-code)
			      [(wheel-up) (scroll -1) #t]
			      [(wheel-down) (scroll 1) #t]
			      [else #f])))])
       (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font 
                             label-font columns column-order)))))

  (define wx-list-box%
    (class wx-label-panel% 
      (init mred proxy parent cb label kind x y w h choices style font label-font columns column-order)
      (inherit get-p set-c)

      (super-init proxy parent label style font 'left 'top)

      (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices 
                             (filter-style style) font label-font columns column-order))
      (set-c c #t #t)

      (bounce
       c
       (get-label-font)
       (set-string i s col)
       (set-selection i)
       (get-selection)
       (get-selections)
       (visible-range)
       (get-first-item)
       (number-of-visible-items)
       (set-first-visible-item i)
       (number)
       (get-row n)
       (set-data i v)
       (get-data i)
       (selected? i)
       (delete i)
       (clear)
       (set choices . more)
       (reset)
       (get-column-order)
       (set-column-order l)
       (set-column-label i l)
       (set-column-size i w mn mx)
       (get-column-size i)
       (delete-column i)
       (append-column l))
      (define/public select 
        (case-lambda
         [(i) (send c select i)]
         [(i on?) (send c select i on?)]
         [(i on? extend?) (send c select i on? extend?)]))
      (define/public append
        (case-lambda
         [(s) (send c append s)]
         [(s v) (send c append s v)]))))

  ;; ----------------------------------------

  (define wx-internal-radio-box%
    (make-window-glue% 
     (class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font)
       (inherit number orig-enable set-selection command)
       (override
	 [enable
	  (case-lambda
	   [(on?) (super enable on?)]
	   [(which on?) (when (< -1 which (number))
			  (vector-set! enable-vector which (and on? #t))
			  (orig-enable which on?))])]
	 [is-enabled?
	  (case-lambda
	   [() (super is-enabled?)]
	   [(which) (and (< -1 which (number))
			 (vector-ref enable-vector which))])])

       (private-field [is-vertical? (memq 'vertical style)])
       (public
	 [vertical? (lambda () is-vertical?)]
	 [char-to-button (lambda (i)
			   (as-exit
			    (lambda ()
			      (set-selection i)
			      (command (make-object wx:control-event% 'radio-box)))))])

       (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))

       (private-field [enable-vector (make-vector (number) #t)]))))

  (define wx-radio-box%
    (class wx-label-panel% 
      (init mred proxy parent cb label x y w h choices major style font)
      (inherit stretchable-in-y stretchable-in-x get-p set-c)

      (super-init proxy parent label style font 'left 'center)

      (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices 
                             major (filter-style style) font))
      (set-c c #t #t)

      (define enable-vector (make-vector (length choices) #t))

      (define/override enable
        (case-lambda
         [(on?) (super enable on?)]
         [(i on?) 
          (when (< -1 i (vector-length enable-vector))
            (vector-set! enable-vector i on?)
            (send c enable-button i on?))]))
      
      (define/override is-enabled?
        (case-lambda
         [() (super is-enabled?)]
         [(which) (and (< -1 which (vector-length enable-vector))
                       (vector-ref enable-vector which))]))

      (bounce 
       c
       (button-focus i)
       (set-selection i)
       (get-selection))
      (stretchable-in-y #f)
      (stretchable-in-x #f)))

  ;; ----------------------------------------

  (define wx-internal-gauge%
    (make-window-glue% 
     (class100 (make-control% wx:gauge% 0 0 #f #f)
	 (parent label range style font)
       (inherit get-client-size get-width get-height set-size 
		stretchable-in-x stretchable-in-y set-min-height set-min-width
		get-parent)
       (override [gets-focus? (lambda () #f)])
       (private-field
	;; # pixels per unit of value.
	[pixels-per-value 1])
       (sequence
	 (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)

	 (let-values ([(client-width client-height) (get-two-int-values 
						     (lambda (a b) (get-client-size a b)))])
	   (let ([delta-w (- (get-width) client-width)]
		 [delta-h (- (get-height) client-height)]
		 [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
		 [horizontal? (memq 'horizontal style)])
	     (set-min-width (if horizontal?
				(let ([cw (min const-max-gauge-length
					       (* range pixels-per-value))])
				  (max (if vertical-labels?
					   cw
					   (+ cw delta-w))
				       (get-width)))
				;; client-height is the default
				;; dimension in the minor direction.
				(+ client-width delta-w)))
	     (set-min-height (if horizontal?
				 (+ client-height delta-h)
				 (let ([ch (min const-max-gauge-length
						(* range pixels-per-value))])
				   (max (if vertical-labels?
					    (+ ch delta-h)
					    ch)
					(get-height)))))))

	 (if (memq 'horizontal style)
	     (begin
	       (stretchable-in-x #t)
	       (stretchable-in-y #f))
	     (begin
	       (stretchable-in-x #f)
	       (stretchable-in-y #t)))))))

  (define wx-gauge%
    (class wx-label-panel% 
      (init mred proxy parent label range style font)
      (inherit stretchable-in-y stretchable-in-x get-p set-c)
      
      (super-init proxy parent label style font 'center 'center)
      
      (define c (make-object wx-internal-gauge% mred proxy (get-p) label range
                             (filter-style style) font))
      (set-c c 
             (memq 'horizontal style)
             (memq 'vertical style))

      (bounce 
       c
       (get-range)
       (set-range rng)
       (get-value)
       (set-value v))
      (let ([h? (and (memq 'horizontal style) #t)])
        (stretchable-in-x h?)
        (stretchable-in-y (not h?)))))

  ;; ----------------------------------------

  (define wx-internal-slider%
    (make-window-glue% 
     (class100 (make-control% wx:slider% 0 0 #f #f)
	 (parent func label value min-val max-val style font)
       (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
		get-client-size get-width get-height get-parent)
       (private-field
	;; # pixels per possible setting.
	[pixels-per-value 3])
       ;; 3 is good because with horizontal sliders under Xt, with 1 or 2
       ;; pixels per value, the thumb is too small to display the number,
       ;; which looks bad.
       
       (sequence
	 (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
	 
	 (let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
								 (get-client-size a b)))])
	   (let* ([horizontal? (memq 'horizontal style)]
		  [vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
		  [range (+ (* pixels-per-value (add1 (- max-val min-val)))
			    (cond
			     [(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
			     [(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
			     [else 0]))])
	     ((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
	      (max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
		   (min const-max-gauge-length range)))
	     (stretchable-in-x horizontal?)
	     (stretchable-in-y (not horizontal?))))))))

  (define wx-slider%
    (class wx-label-panel% 
      (init mred proxy parent func label value min-val max-val style font)
      (inherit stretchable-in-y stretchable-in-x get-p set-c)

      (super-init proxy parent label style font 'center 'center)

      (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val
                             (filter-style style) font))
      
      (set-c c 
             (memq 'horizontal style)
             (memq 'vertical style))
      
      (bounce 
       c
       (get-value)
       (set-value v))
      (let ([h? (and (memq 'horizontal style) #t)])
        (stretchable-in-x h?)
        (stretchable-in-y (not h?)))))
  
)
