(module wxtabgroup mzscheme
  (require mzlib/class
	   (prefix wx: "kernel.ss")
	   "lock.ss"
	   "wx.ss"
	   "const.ss"
	   "gdi.ss"
	   "helper.ss"
	   "wxwindow.ss"
	   "wxitem.ss"
	   "wxcanvas.ss")

  (provide (protect wx-tab-group%
		    canvas-based-tab-group%))

  (define mac-tab? (eq? 'macosx (system-type)))

  (define tab-v-space 2)
  (define raise-h (if mac-tab? 0 2))

  (define canvas-based-tab-group%
    (class* wx-canvas% (wx-tab-group<%>)
      (init mred proxy style parent call-back label tab-labels style-again _font)
      
      (define callback call-back)

      (define tabs (map wx:label->plain-label tab-labels))
      (define tab-widths #f)
      (define tab-height #f)

      (define current-focus-tab 0)
      
      (define font (or _font normal-control-font))
      
      (inherit get-dc get-client-size get-mred
	       set-min-width set-min-height
	       set-tab-focus set-focus has-focus?
	       set-background-to-gray refresh
	       get-top-level is-enabled-to-root?)
      
      (define selected 0)
      (define tracking-pos #f)
      (define tracking-hit? #f)
      
      (define regions #f)
      (define redo-regions? #f)

      (define border? (memq 'border style))

      (define/private (compute-sizes)
	(let ([dc (get-dc)])
	  (let ([w+hs (map (lambda (lbl)
			     (let-values ([(w h d a) (send dc get-text-extent lbl font)])
			       (cons w h)))
			   tabs)])
	    (set! tab-widths (map car w+hs))
	    (if mac-tab?
		(set! tab-height (+ 27 (send font get-point-size) -13))
		(let-values ([(sw sh sd sa) (send dc get-text-extent " " font)])
		  (let ([th (ceiling (+ (* 2 tab-v-space) (apply max 0 sh (map cdr w+hs))))])
		    (set! tab-height (if (even? th) th (add1 th)))))))))
      
      (define/private (get-total-width)
	(compute-sizes)
	(apply + 
	       (if mac-tab? 0 tab-height)
	       (* (length tabs) (+ raise-h raise-h tab-height)) 
	       tab-widths))
      
      (define/private (get-init-x)
	(if border?
	    (let-values ([(w h) (my-get-client-size)]
			 [(tw) (get-total-width)])
	      (/ (- w tw) 2))
	    (if mac-tab?
		2
		0)))

      (define/override (on-char e) (void))

      (define/override on-event
	(entry-point
	 (lambda (e)
	   (cond
	    [(and (send e button-down?) tab-widths)
	     (set! tracking-pos (find-click (send e get-x) (send e get-y)))
	     (when tracking-pos
	       (set! current-focus-tab tracking-pos)
	       (set! tracking-hit? #t)
	       (update-tracking))]
	    [(and (send e dragging?) tracking-pos)
	     (let ([hit? (equal? tracking-pos (find-click (send e get-x) (send e get-y)))])
	       (unless (eq? tracking-hit? hit?)
		 (set! tracking-hit? hit?)
		 (update-tracking)))]
	    [(and (send e button-up?) tracking-pos
		  (equal? tracking-pos (find-click (send e get-x) (send e get-y)))
		  (not (= tracking-pos selected)))
	     ;; Button released for final selection
	     (let ([new tracking-pos])
	       (set! tracking-pos #f)
	       (set! tracking-hit? #f)
	       (set-selection new)
	       (as-exit
		(lambda ()
		  (callback this (make-object wx:control-event% 'tab-panel)))))]
	    ;; otherwise, turn off tracking...
	    [else
	     (when tracking-hit?
	       (set! tracking-hit? #f)
	       (update-tracking))
	     (set! tracking-pos #f)]))))
      
      (define/private (update-tracking)
	(if mac-tab?
	    (refresh)
	    (let ([dc (get-dc)])
	      (send dc set-clipping-region (list-ref regions tracking-pos))
	      (on-paint)
	      (send dc set-clipping-region #f))))
	
      (define tmp-rgn #f)

      (define/public (button-focus n)
	(if (< n 0)
	    current-focus-tab
	    (begin
	      (set! current-focus-tab n)
	      (refresh)
	      (set-focus)
	      current-focus-tab)))

      (define/override on-set-focus
	(lambda ()
	  (refresh)
	  (super on-set-focus)))
      (define/override on-kill-focus
	(lambda ()
	  (refresh)
	  (super on-kill-focus)))
      
      (define/private (find-click x y)
	(ready-regions)
	(unless tmp-rgn
	  (set! tmp-rgn (make-object wx:region% (get-dc))))
	(let loop ([rl regions][pos 0])
	  (if (null? rl)
	      #f
	      (begin
		(send tmp-rgn set-rectangle x y 1 1)
		(send tmp-rgn intersect (car rl))
		(if (send tmp-rgn is-empty?)
		    (loop (cdr rl) (add1 pos))
		    pos)))))
      
      (define/private (setup-regions)
	(let ([dc (get-dc)])
	  (set! regions
		(map (lambda (tpl r)
		       (let ([points (map (lambda (p) (make-object wx:point% (car p) (+ 2 raise-h (cadr p))))
					  tpl)])
			 (send r set-polygon points))
		       r)
		     (draw-once #f 0 #f #f 0 #f)
		     (if regions
			 regions
			 (map (lambda (x)
				(make-object wx:region% dc))
			      tabs))))
	  (set! redo-regions? #f)))

      (define/private (ready-regions)
	(compute-sizes)
	(unless (and regions (not redo-regions?)) 
	  (setup-regions)))

      (define/override (gets-focus?) #t)    
      (define/override (tabbing-position x y w h)
	(list this (+ x (get-init-x)) y (get-total-width) tab-height))
      (define/public (number) (length tabs))
      
      ;; Returns a list of point lists, which define polygons for hit-testing
      ;;  and updating
      (define/private (draw-once dc w light? dark? inset active?)
	(let ([init-x (get-init-x)])
	  (let loop ([x init-x][l tabs][wl tab-widths][pos 0])
	    (if (null? l)
		null
		(let ([next-x (+ x tab-height (car wl))]
		      [-sel-d (if (= pos selected) (- raise-h) 0)])
		  (cons
		   (if mac-tab?
		       ;; ----- Mac drawing -----
		       (let ([w (+ tab-height (car wl))]
			     [h tab-height])
			 (when dc
			   (when (eq? dark? (= pos selected))
			     (wx:draw-tab 
			      dc
			      (car l) x 3 w (- tab-height 3)
			      (+ (if (and (has-focus?)
					  (= pos current-focus-tab))
				     ;; Adding 100 means "draw focus ring"
				     100
				     ;; No focus
				     0)
				 ;; Pick the style: active and front, etc.
				 (if (and light?
					  (eq? pos tracking-pos))
				     1
				     (if active?
					 (if dark? 3 0)
					 (if dark? 4 2)))))))
			 (list (list x 3) (list (+ x w) 3)
			       (list (+ x w) (- tab-height 6)) (list x (- tab-height 6))))
		       ;; ----- X-style drawing -----
		       (append
			;; start point
			(list (list (+ x tab-height -sel-d inset) (+ 2 tab-height (- inset))))
			;; left line
			(begin
			  (when (= pos selected)
			    (when light?
			      (send dc set-pen border-pen)
			      (send dc draw-line 0 tab-height (sub1 x) tab-height)
			      (send dc set-pen light-pen)
			      (send dc draw-line 0 (add1 tab-height) (sub1 x) (add1 tab-height))))
			  (let ([short (if (or (= pos 0) (= pos selected))
					   0
					   (+ (/ tab-height 2) 
					      (if (= selected (sub1 pos))
						  raise-h
						  0)))])
			    (when light?
			      (send dc set-pen border-pen)
			      (send dc draw-line (+ x short -sel-d) (- tab-height short) (+ x tab-height) -sel-d)
			      (send dc set-pen light-pen)
			      (send dc draw-line (+ x short -sel-d 1) (- tab-height short) (+ x tab-height 1) -sel-d))
			    (list (list (+ x short -sel-d -2 inset) (- tab-height short -2 inset))
				  (list (+ x tab-height inset) (+ -sel-d inset)))))
			;; top line
			(begin
			  (when light?
			    (send dc set-pen border-pen)
			    (send dc draw-line (+ x tab-height) -sel-d next-x -sel-d)
			    (send dc set-pen light-pen)
			    (send dc draw-line (+ x tab-height) (+ 1 -sel-d) next-x (+ 1 -sel-d)))
			  (list (list (+ 1 next-x (- inset)) (+ inset -sel-d))))
			;; right line
			(let* ([short (if (= (add1 pos) selected)
					  (+ (/ tab-height 2) (sub1 raise-h))
					  0)]
			       [short-d (if (zero? short) 0 -1)])
			  (when dark?
			    (send dc set-pen border-pen)
			    (send dc draw-line next-x (+ -sel-d 1) 
				  (- (+ next-x tab-height) short 2 -sel-d short-d) (- tab-height short 1 short-d))
			    (send dc set-pen dark-pen)
			    (send dc draw-line (+ 1 next-x) (+ -sel-d 1) (- (+ next-x tab-height) short 1 -sel-d) (- tab-height short 1)))
			  (list (list (- (+ next-x tab-height) -sel-d short (- short-d) -2 inset) (- tab-height short -2 inset))))
			;; end point
			(begin
			  (when light?
			    (when (= pos selected)
			      (send dc set-pen border-pen)
			      (send dc draw-line (+ next-x tab-height) tab-height w tab-height)
			      (send dc set-pen light-pen)
			      (send dc draw-line (+ next-x tab-height) (add1 tab-height) w (add1 tab-height)))
			    (let ([x (+ x tab-height)]
				  [y (- tab-v-space (if (= pos selected) raise-h 0))])
			      (send dc set-text-foreground
				    (if (is-enabled-to-root?)
					black-color
					disabled-color))
			      (send dc draw-text (car l) x y)
			      (when (and (has-focus?)
					 (= pos current-focus-tab))
				(let ([p (send dc get-pen)])
				  (send dc set-pen "black" 1 'hilite)
				  (let ([x (- x 1)]
					[y (+ y 2)]
					[w (+ (car wl) 2)]
					[h (- tab-height (* 2 tab-v-space) 2)])
				    (send dc draw-line (+ x 0) (+ y -1) (+ x w -1) (+ y -1))
				    (send dc draw-line (+ x 0) (+ y h) (+ x w -1) (+ y h))
				    (send dc draw-line (+ x -1) (+ y 0) (+ x -1) (+ y h -1))
				    (send dc draw-line (+ x w) (+ y 0) (+ x w) (+ y h -1)))
				  (send dc set-pen p)))))
			  (list (list (+ next-x inset (if (= selected (add1 pos)) -2 0)) (+ 2 tab-height (- inset)))))))
		   (loop next-x (cdr l) (cdr wl) (add1 pos))))))))

      
      (define/override on-paint
	(entry-point
	 (lambda ()
	   (compute-sizes)
	   (let ([dc (get-dc)]
		 [active? (and (is-enabled-to-root?)
			       (send (get-top-level) is-act-on?))])
	     (send dc set-background bg-color)
	     (send dc set-font font)
	     (unless mac-tab?
	       (send dc clear)
	       (send dc set-origin 0 (+ 2 raise-h))
	       (when (and tracking-pos tracking-hit?)
		 (let ([b (send dc get-brush)])
		   (send dc set-brush dark-brush)
		   (send dc set-pen trans-pen)
		   (send dc draw-polygon (map (lambda (x) (make-object wx:point% (car x) (cadr x)))
					      (list-ref (draw-once #f 0 #f #f 1 #f) tracking-pos)))
		   (send dc set-brush b))))
	     (let-values ([(w h) (my-get-client-size)])
	       (unless mac-tab?
		 (send dc set-pen light-pen))
	       (draw-once dc w #t #f 0 active?)
	       (when mac-tab?
		 (wx:draw-tab-base dc 0 (- tab-height 3) w 6 (if active? 1 0)))
	       (when border?
		 (when (> h tab-height)
		   (send dc draw-line 1 (add1 tab-height) 1 h)
		   (send dc set-pen border-pen)
		   (send dc draw-line 0 tab-height 0 h)))
	       (unless mac-tab?
		 (send dc set-pen dark-pen))
	       (draw-once dc w #f #t 0 active?)
	       (when border?
		 (when (> h tab-height)
		   (send dc draw-line (- w 2) (+ 1 tab-height) (- w 2) (- h raise-h))
		   (send dc draw-line 1 (- h 4 raise-h) w (- h 4 raise-h))
		   (send dc set-pen border-pen)
		   (send dc draw-line (- w 1) tab-height (- w 1) (- h raise-h))
		   (send dc draw-line 0 (- h 3 raise-h) w (- h 3 raise-h)))))
	     (send dc set-origin 0 0)))))

      (define/override (on-size w h)
	(set! redo-regions? #t)
	(super on-size w h))

      (define/private (my-get-client-size)
	(get-two-int-values (lambda (a b) (get-client-size a b))))
      
      (define/public (get-selection)
	selected)

      (define/public (set-selection i)
	(ready-regions)
	(when (< -1 i (length regions))
	  (let* ([dc (get-dc)]
		 [r (make-object wx:region% dc)]
		 [old-rgn (list-ref regions selected)])
	    (set! selected i)
	    (send r union old-rgn)
	    (setup-regions)
	    (if mac-tab?
		(refresh) ;; but we need an immediate refresh!
		(let ([new-rgn (list-ref regions selected)])
		  ;; Union the new and old regions and repaint:
		  (send r union new-rgn)
		  (send dc set-clipping-region r)
		  (on-paint)
		  (send dc set-clipping-region #f))))))

      (define/public (set-label i s)
        (set! tabs (let loop ([tabs tabs][i i])
                     (if (zero? i)
                         (cons (wx:label->plain-label s) (cdr tabs))
                         (cons (car tabs) (loop (cdr tabs) (sub1 i))))))
	(set! tab-widths #f)
	(set! regions #f)
	(refresh))

      (define/public (set tab-labels)
	(set! tabs (map wx:label->plain-label tab-labels))
	(set! tab-widths #f)
	(set! regions #f)
	(set! selected (max 0 (min selected (sub1 (length tabs)))))
	(refresh))

      (define (-append s)
	(set! tabs (append tabs (list (wx:label->plain-label s))))
	(set! tab-widths #f)
	(set! regions #f)
	(refresh))
      (public (-append append))

      (define/public (delete i)
	(set! tabs (let loop ([pos 0][tabs tabs])
		     (if (= i pos)
			 (cdr tabs)
			 (cons (car tabs) (loop (add1 pos) (cdr tabs))))))
	(set! selected (min (if (selected . <= . i)
				selected
				(sub1 selected))
			    (max 0 (sub1 (length tabs)))))
	(set! regions #f)
	(set! tab-widths #f)
	(refresh))
      
      (define/override (handles-key-code code alpha? meta?) 
	#f)

      (super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
      
      (let ([focus-ok? 
	     ;; For Mac OS X, this method indicates that the
	     ;;  canvas should not necessarily get the focus
	     ;;  on a click, and the result indicates whether
	     ;;  it should accept tab focus in general
	     (set-background-to-gray)])

	(compute-sizes)
	(set-min-width (inexact->exact (ceiling (get-total-width))))
	(set-min-height (inexact->exact (ceiling (+ tab-height (if mac-tab? 6 9) raise-h))))
	(when mac-tab?
	  (send (get-top-level) add-activate-update this))
	(set-tab-focus focus-ok?))))

  (define wx-tab-group% 
    (if (eq? 'unix (system-type))
	canvas-based-tab-group%
	(class* (make-window-glue%
		 (make-control% wx:tab-group% 0 0 #t #t)) (wx-tab-group<%>)
	  (inherit min-height)
	  (define/override (tabbing-position x y w h)
	    (list this x y w (min-height)))
	  (define/override (handles-key-code code alpha? meta?) #f)
	  (super-instantiate ())))))