320 lines
8.8 KiB
Bash
Executable File
320 lines
8.8 KiB
Bash
Executable File
#!/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)
|
|
|
|
|