(unit/sig lights-out:gui^
  (import mred^
	  lights-out:board^)

  (define frame (make-object frame% "Lights Out"))
  
  (define label-size 30)
  
  (define orange (make-object color% 255 165 0))
  (define light-orange (make-object color% 255 220 100))

  (define on-pen (send the-pen-list find-or-create-pen orange 1 'solid))
  (define on-brush (send the-brush-list find-or-create-brush orange 'solid))
  (define off-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
  (define off-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))

  (define dull-on-pen (send the-pen-list find-or-create-pen light-orange 1 'solid))
  (define dull-on-brush (send the-brush-list find-or-create-brush light-orange 'solid))
  (define dull-off-pen (send the-pen-list find-or-create-pen "DARK GRAY" 1 'solid))
  (define dull-off-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid))

  (define (flip-one i j)
    (when (and (<= 0 i (- (vector-length current-board) 1))
	       (<= 0 j (- (vector-length current-board) 1)))
      (vector-set!
       (vector-ref current-board j)
       i
       (case (vector-ref (vector-ref current-board j) i)
	 [(x) 'o]
	 [(o) 'x]))))

  (define (flip-surrounding i j)
    (flip-one i j)
    (flip-one (- i 1) j)
    (flip-one i (- j 1))
    (flip-one (+ i 1) j)
    (flip-one i (+ j 1)))
  
  (define current-board #f)
  (define original-board #f)

  (define board-canvas%
    (class canvas% ()
      (inherit get-dc)
      (private
	[dull-i 1]
	[dull-j 1]
	[width 10]
	[height 10]
	[tile->screen
	 (lambda (i j)
	   (let ([x (inexact->exact (floor (* (/ i (vector-length current-board)) (- width 2))))]
		 [y (inexact->exact (floor (* (/ j (vector-length current-board)) (- height 2))))]
		 [w (inexact->exact (floor (* (/ (- width 2) (vector-length current-board)))))]
		 [h (inexact->exact (floor (* (/ (- height 2) (vector-length current-board)))))])
	     (values (+ x 2)
		     (+ y 2)
		     (max 0 (- w 2))
		     (max 0 (- h 2)))))]
	[screen->tile
	 (lambda (x y)
	   (values (inexact->exact (floor (* (/ x width) (vector-length current-board))))
		   (inexact->exact (floor (* (/ y height) (vector-length current-board))))))]
	[draw-tile
	 (lambda (dc i j)
	   (when (and (<= 0 i (- (vector-length current-board) 1))
		      (<= 0 j (- (vector-length current-board) 1)))
	     (let ([ent (vector-ref (vector-ref current-board j) i)]
		   [dull? (and dull-i
			       dull-j
			       (or (and (= i dull-i)
					(= j dull-j))
				   (and (= i (- dull-i 1))
					(= j dull-j))
				   (and (= i (+ dull-i 1))
					(= j dull-j))
				   (and (= i dull-i)
					(= j (- dull-j 1)))
				   (and (= i dull-i)
					(= j (+ dull-j 1)))))])
	       (if dull?
		   (if (eq? ent 'x)
		       (begin
			 (send dc set-pen dull-off-pen)
			 (send dc set-brush dull-off-brush))
		       (begin
			 (send dc set-pen dull-on-pen)
			 (send dc set-brush dull-on-brush)))
		   (if (eq? ent 'x)
		       (begin
			 (send dc set-pen on-pen)
			 (send dc set-brush on-brush))
		       (begin
			 (send dc set-pen off-pen)
			 (send dc set-brush off-brush)))))
	     (let-values ([(x y w h) (tile->screen i j)])
	       (send dc draw-rectangle x y w h))))]
	[get-changed
	 (lambda (x y)
	   (if (and x y)
	       (list (cons x y)
		     (cons (+ x 1) y)
		     (cons (- x 1) y)
		     (cons x (- y 1))
		     (cons x (+ y 1)))
	       null))])
      (public
	[redraw
	 (lambda ()
	   (let* ([dc (get-dc)])
	     (let loop ([j (vector-length current-board)])
	       (cond
		[(zero? j) (void)]
		[else
		 (let loop ([i (vector-length current-board)])
		   (cond
		    [(zero? i) (void)]
		    [else
		     (draw-tile dc
				(- i 1)
				(- j 1))
		     (loop (- i 1))]))
		 (loop (- j 1))]))))])
      (override
	[on-size
	 (lambda (w h)
	   (set! width w)
	   (set! height h))]
	[on-event
	 (lambda (evt)
	   (cond
	    [(send evt button-up?)
	     (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))])
	       (flip-surrounding x y)
	       (redraw))]
	    [(send evt leaving?)
	     (let ([changed (get-changed dull-i dull-j)])
	       (set! dull-i #f)
	       (set! dull-j #f)
	       (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair)))
			 changed))]
	    [(send evt moving?)
	     (let ([changed-one (get-changed dull-i dull-j)])
	       (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))])
		 (set! dull-i x)
		 (set! dull-j y))
	       (let ([changed-two (get-changed dull-i dull-j)])
		 (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair)))
			   (append changed-one changed-two))))]
	    [else (void)]))]
	[on-paint
	 (lambda ()
	   (send (get-dc) clear)
	   (redraw))])
      (sequence
	(super-init frame))))
  
  (define board-canvas (make-object board-canvas%))
  (send board-canvas min-width 100)
  (send board-canvas min-height 100)

  (define (copy-board board)
    (list->vector
     (map (lambda (x) (list->vector (vector->list x)))
	  (vector->list board))))

  (define (init-board new-board)
    (set! current-board new-board)
    (set! original-board (copy-board new-board))
    (send board-canvas on-paint))
  
  (define button-panel (make-object horizontal-panel% frame))
  
  (make-object button% "New" button-panel
	       (lambda x
		 (let ([res (new-board)])
		   (when res
		     (init-board res)))))
  
  (make-object button% "Reset" button-panel
	       (lambda x
		 (init-board original-board)))
  
  (let ([help ((require-library "show-help.ss" "games")
	       (list "games" "lights-out")
	       "Lights Out Help")])
    (make-object button% "Help" button-panel
		 (lambda x
		   (help))))
  
  (make-object grow-box-spacer-pane% button-panel)
  (send button-panel stretchable-height #f)

  (init-board (random-board (+ 3 
			       (random 2)
			       (random 2)
			       (random 2)
			       (random 2)
			       (random 2))))
  ;(send frame stretchable-width #f)
  ;(send frame stretchable-height #f)
  (send frame show #t))