#!/bin/sh
:;exec /usr/local/bin/stk -f "$0" "$@"

; -* Scheme -*-

; 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.
;
; It expects to fined the queen bitmap in the images directory 
; in the STk library directory.

; 27 Jan 96: ported to STk 3.0

; Grant Edwards
;
; grante@winternet.com
; grante@rosemount.com
; grante@ep.frco.com
; edwards@grad.cs.umn.edu



(define queen-bitmap (string-append "@" *STk-library* "/Images/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 :relief 'raised :borderwidth 2)
(frame '.upper)

; procedure that does nothing other than return the break symbol

(define noop-break (lambda () 'break))


; 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
			  :highlightthickness 0
			  :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>" (lambda () (toggle-button x y) 'break))
	    (bind bn "<Any-Enter>" noop-break)
	    (bind bn "<Any-Leave>" noop-break)
	    (bind bn "<ButtonRelease-1>"  noop-break)
	    (pack bn :side 'left)
	    )
      )
    (pack rowframe :side 'bottom)
    )
  )


; add control buttons to upper frame

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

; arrange the two top level frames

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