#!/usr/local/bin/stk -file
;
; This demo is a contribution of Grant Edwards (grante@rosemount.com)
;


; Yet another "my first STk program" type thing.  This one is the "8
; queens" puzzle.  You try to figure out how to place 8 queens on a
; chessboard so that none of the queens can be taken in a single move.

; You can do it yourself (and it will make sure you follow the rules)
; or you can ask it to solve the puzzle starting with a given board
; configuration.


(define queen-bitmap (string-append "@" tk_library "/bitmaps/queen"))

; size of board (it's square)

(define size 8)


; Predicate that is true if the queens at p1 and p2 can't take each
; other in 1 move.  p1 and p2 are pairs of the form ( x . y ) where
; x is column and y is row (both from 0 to size-1).

(define legal-position-pair? 
  (lambda (p1 p2)
    (let ([x1 (car p1)] [y1 (cdr p1)] [x2 (car p2)] [y2 (cdr p2)])
      (not (or 
	    (= x1 x2) 
	    (= y1 y2) 
	    (= (abs (- x1 x2)) (abs (- y1 y2))))))))


; Predicate that is true if none of the queens in list history can
; take queen at postion new in one move.  "history" is a list of
; position pairs.  "new" is the position pair which we are testing.

(define legal-move? 
  (lambda (history new)
    (cond 
     [(null? history) #t]
     [(not (legal-position-pair? (car history) new)) #f]
     [else (legal-move? (cdr history) new)])))


; This is the procedure that solves the puzzle given a list of
; occupied squares and a list of empty rows.  It's also passed a
; continuation so that it can abort when the user asks it to stop.

; Add a legal move to history list and recurse to build up strings of
; legal moves.  The chessboard is updated as pieces are placed. When
; it reaches the required length, it waits for user to press the Next
; or Stop button. "history" is a list of pairs that denotes where
; there are already queens.  "ylist" is a list of rows that still need
; to be filled. "break" is a continuation to be called when the
; procedure is to be aborted.

(define add-queen 
  (lambda (history ylist break)
    (cond
     [stopPushed    (break #f)]
     [(null? ylist) (begin (write history)(newline)(waitForNextButton)(if stopPushed (break #f)))]
     [else          (let ([newy (car ylist)])
		      (dotimes (newx size)
			       (if (legal-move? history (cons newx newy))
				   (begin
				    (activate-button newx newy)
				    (update)
				    (add-queen (cons (cons newx newy) history) (cdr ylist) break)
				    (deactivate-button newx newy)
				    (update)))))])))

; global boolean used to keep track of whether or not the user is
; allowed to rearrange the board.

(define userModsEnabled #t)


; set up button states and solve the puzzle starting with the current
; board configuration.

(define do-solve 
  (lambda ()
    (set! stopPushed #f)
    (.upper.solve 'configure :state 'disabled)
    (.upper.stop  'configure :state 'normal)
    (.upper.clear 'configure :state 'disabled)
    (set! userModsEnabled #f)
    (call/cc (lambda (break)(add-queen (current-positions)(empty-rows) break)))
    (.upper.stop 'configure :state 'disabled)
    (.upper.clear 'configure :state 'normal)
    (set! userModsEnabled #t)
    (.upper.solve 'configure :state 'normal)))


; define some procedures to create and operate on matrixes

(define make-matrix 
  (lambda (i j v) 
    (let ([m (make-vector i)])
      (dotimes (c j m)
	       (vector-set! m c (make-vector j v))))))

(define matrix-ref 
  (lambda (m i j)
    (vector-ref (vector-ref m i) j)))

(define matrix-row 
  (lambda (m i)
    (vector-ref m i)))

(define matrix-set! 
  (lambda (m i j v)
    (vector-set! (vector-ref m i) j v)))


; Create two matrixes.  Each has an entry for each square on the
; board.  One matrix is Tk button procedures, the other is booleans
; that reflect whether or not the square is occupied.

(define board-buttons (make-matrix size size #f))
(define board-states  (make-matrix size size #f))
  

; redraw the button so that it is occupied and update the matrix of
; booleans

(define activate-button 
  (lambda (x y)
    ((matrix-ref board-buttons y x) 'configure ':relief 'raised :foreground "#000")
    (matrix-set! board-states y x #t)))


; redraw the button so that it is empty and update the matrix of
; booleans

(define deactivate-button 
  (lambda (x y)
    (let* ([b (matrix-ref board-buttons y x)]
	      [bg (cadr (cdddr (b 'configure :background)))])
      (b 'configure :relief 'flat :foreground bg)
      (matrix-set! board-states y x #f))))

; flash a button

(define flash-button 
  (lambda (x y)
    ((matrix-ref board-buttons y x) 'flash)))


; Procedure called when the user clicks on a square in the chessboard.
; If user modifications are not enabled, then do nothing.  Otherwise
; toggle the sate of the square.  When placing a queen on a previously
; empty square, remove existing queens that could be taken by the new
; one.

(define toggle-button 
  (lambda (x y)
    (cond
     [ (not userModsEnabled) #f]
     [ (matrix-ref board-states y x)  (deactivate-button x y)]
     [else (begin
	    (activate-button x y)
	    (update)
	    (dotimes (ox size) 
		     (dotimes (oy size)
			      (if (and
				   (matrix-ref board-states  oy ox)
				   (not (and (= x ox) (= y oy)))
				   (not (legal-position-pair? (cons x y) (cons ox oy))))
				  (begin
				   (flash-button ox oy)
				   (flash-button ox oy)
				   (flash-button ox oy)
				   (deactivate-button ox oy)
				   (update))))))])))


; clear the board

(define clear-board 
  (lambda ()
    (dotimes (x size) (dotimes (y size) (deactivate-button x y)))))


; Procedures to return a list of consecutive integers from start to
; end (inclusive).

(define interval 
  (lambda (start end)
    (let loop ([s start] [e end] [l ()])
	 (if (> s e) l (loop s (- e 1) (cons e l))))))

(define rinterval 
  (lambda (start end)
    (let loop ([s start] [e end] [l ()])
	 (if (> s e) l (loop (+ s 1) e (cons s l))))))
   

; Return a list of integers that identify the rows on the chessboard
; that are empty

(define empty-rows 
  (lambda ()
    (let loop ([rows (rinterval 0 (- size 1))] [empty ()])
	 (if (null? rows)
	     empty
	   (if (member #t (vector->list (matrix-row board-states (car rows))))
	       (loop (cdr rows) empty)
	     (loop (cdr rows) (cons (car rows) empty)))))))


; Return a list of pairs ( x . y ) indicating which squares are
; currently occupied.

(define current-positions 
  (lambda ()
    (let ([p ()])
      (dotimes (x size) 
	       (dotimes (y size) 
			(if (matrix-ref board-states y x) (set! p (cons (cons x y) p)))))
      p)))


; Booleans used to detect when user presses a button 

(define nextOrStopPushed #f)
(define stopPushed #f)


; Procedure to wait for the user to press either the next or stop
; buttons.

(define waitForNextButton 
  (lambda () 
    (.upper.next 'configure :state 'normal)
    (tkwait 'variable 'nextOrStopPushed)
    (.upper.next 'configure :state 'disabled)))


; Define two frames.  The upper will hold control buttons, the lower
; the chessboard buttons

(frame '.lower)
(frame '.upper :relief 'raised :borderwidth 2)


; add a frame to the lower frame for each row of sqaures on the
; chessboard and fill that row with buttons (one per square).

(dotimes (y size)
	 (let ([rowframe (format #f ".lower.row~a" y)])
	   (frame rowframe)
	   (dotimes (x size)
		    (let* ([bn (format #f "~a.b~a" rowframe x)]
			       [bp (eval (button bn 
						 :bitmap queen-bitmap
						 :relief 'flat))])
		      (matrix-set! board-buttons y x bp)
		      (let ([bg (if (odd? (+ x y)) "#bbb" "#eee")])
			(bp 'configure :background bg :activebackground "#fff" :foreground bg))
		      (bind bn "<Button-1>" (format #f "(toggle-button ~a ~a)" x y))
		      (bind bn "<Any-Enter>" '() )
		      (bind bn "<Any-Leave>" '() )
		      (bind bn "<ButtonRelease-1>" '() )
		      (pack bn :side 'left)
		      )
		    )
	   (pack rowframe :side 'bottom)
	   )
	 )


; add control buttons to upper frame

(button '.upper.quit  :text "Quit" :command '(exit))
(frame  '.upper.fill)
(button '.upper.solve :text "Solve" :command '(do-solve))
(button '.upper.Clear :text "Clear" :command '(clear-board))
(button '.upper.next 
	:text "Next" 
	:state 'disabled 
	:command '(begin (set! stopPushed #f)(set! nextOrStopPushed #t)))
(button '.upper.stop 
	:text "Stop" 
	:state 'disabled 
	:command '(begin (set! stopPushed #t)(set! nextOrStopPushed #t)))

(pack '.upper.solve :side 'left :padx 4 :pady 4)
(pack '.upper.next :side 'left :padx 4 :pady 4)
(pack '.upper.stop :side 'left :padx 4 :pady 4)
(pack '.upper.clear :side 'left :padx 4 :pady 4)
(pack '.upper.quit :side 'right :padx 4 :pady 4)
(pack '.upper.fill :side 'right :fill 'x)

; arrange the two top level frames

(pack '.upper :side 'top :fill 'x)
(pack '.lower :side 'bottom)