To finish off, we our complete 8-queens program.
Here is the Prolog part, which we have covered in previous
sections. The code is in library('tcltk/examples/8-queens.pl'):
% 8-queens.pl
:- use_module(library(tcltk)).
:- use_module(library(lists)).
setup :-
tk_new([name('SICStus+Tcl/Tk - Queens')], Tcl),
tcl_eval(Tcl, 'source 8-queens.tcl', _),
tk_next_event(Tcl, Event),
( Event = next -> go(Tcl)
; closedown(Tcl)
).
closedown(Tcl) :-
tcl_delete(Tcl).
go(Tcl) :-
tcl_eval(Tcl, 'clear_board', _),
queens(8, Qs),
show_solution(Tcl,Qs),
tk_next_event(Tcl, Event),
( Event = next -> fail
; closedown(Tcl)
).
go(Tcl) :-
tcl_eval(Tcl, 'disable_next', _),
tcl_eval(Tcl, 'clear_board', _),
tk_next_event(Tcl, _Event),
closedown(Tcl).
% 8-queens.pl
queens(N, Qs) :-
range(1, N, Ns),
queens(Ns, [], Qs).
queens(UnplacedQs, SafeQs, Qs) :-
select(Q, UnplacedQs, UnplacedQs1),
\+ attack(Q, SafeQs),
queens(UnplacedQs1, [Q|SafeQs], Qs).
queens([], Qs, Qs).
attack(X, Xs) :- attack(X, 1, Xs).
attack(X, N, [Y|_Ys]) :- X is Y + N.
attack(X, N, [Y|_Ys]) :- X is Y - N.
attack(X, N, [_Y|Ys]) :-
N1 is N + 1,
attack(X, N1, Ys).
range(M, N, [M|Ns]) :-
M < N,
M1 is M + 1,
range(M1, N, Ns).
range(N, N, [N]).
show_solution(Tcl, L) :-
reverse(L, LR),
tcl_eval(Tcl, [show_solution, br(LR)], _),
tk_do_all_events.
tk_do_all_events :-
tk_do_one_event, !,
tk_do_all_events.
tk_do_all_events.
:- setup.
And here is the Tcl/Tk part, which we have covered in bits and pieces
but here is the whole thing. We have added an enhancement
where when the mouse is moved over one of the queens, the squares
that the queen attacks are highlighted. Move the mouse away and
the board reverts to normal. This is an illustration of how
the Tcl/Tk bind feature can be used.
The code is in library('tcltk/examples/8-queens.tcl'):
# 8-queens.tcl
#! /usr/bin/wish
# create an 8x8 grid of labels
proc setup_display { } {
frame .queens -background black
pack .queens
for {set y 1} {$y <= 8} {incr y} {
for {set x 1} {$x <= 8} {incr x} {
# create a label and display a queen in it
label .queens.$x-$y -bitmap @bitmaps/q64s.bm -relief flat
# color alternate squares with different colors
# to create the chessboard pattern
if { [expr ($x + $y) % 2] } {
.queens.$x-$y config -background #ffff99
} else {
.queens.$x-$y config -background #66ff99
}
# set foreground to the background color to
# make queen image invisible
.queens.$x-$y config -foreground [.queens.$x-$y cget -background]
# bind the mouse to highlight the squares attacked by a
# queen on this square
bind .queens.$x-$y <Enter> "highlight_attack on $x $y"
bind .queens.$x-$y <Leave> "highlight_attack off $x $y"
# arrange the queens in a grid
grid .queens.$x-$y -row $y -column $x -padx 1 -pady 1
}
}
}
# 8-queens.tcl
# clear a whole column
proc reset_column { column } {
for {set y 1 } { $y <= 8 } {incr y} {
set_queens $column $y ""
}
}
# place or unplace a queen
proc set_queens { x y v } {
if { $v == "Q" } {
.queens.$x-$y config -foreground black
} else {
.queens.$x-$y config -foreground [.queens.$x-$y cget -background]
}
}
# place a queen on a column
proc place_queen { x y } {
reset_column $x
set_queens $x $y Q
}
# clear the whole board by clearing each column in turn
proc clear_board { } {
for { set x 1 } {$x <= 8} {incr x} {
reset_column $x
}
}
# given a solution as a list of queens in column positions
# place each queen on the board
proc show_solution { solution } {
clear_board
set x 1
foreach y $solution {
place_queen $x $y
incr x
}
}
# 8-queens.tcl
proc highlight_square { mode x y } {
# check if the square we want to highlight is on the board
if { $x < 1 || $y < 1 || $x > 8 || $y > 8 } { return };
# if turning the square on make it red,
# otherwise determine what color it should be and set it to that
if { $mode == "on" } { set color red } else {
if { [expr ($x + $y) % 2] } { set color "#ffff99" } else {
set color "#66ff99" }
}
# get the current settings
set bg [ .queens.$x-$y cget -bg ]
set fg [ .queens.$x-$y cget -fg ]
# if the current foreground and background are the same
# there is no queen there
if { $bg == $fg } {
# no queens
.queens.$x-$y config -bg $color -fg $color
} else {
.queens.$x-$y config -bg $color
}
}
proc highlight_attack { mode x y } {
# get current colors of square at x y
set bg [ .queens.$x-$y cget -bg ]
set fg [ .queens.$x-$y cget -fg ]
# no queen there, give up
if { $bg == $fg } { return };
# highlight the sqaure the queen is on
highlight_square $mode $x $y
# highlight vertical and horizontal
for { set i 1 } {$i <= 8} {incr i} {
highlight_square $mode $x $i
highlight_square $mode $i $y
}
# highlight diagonals
for { set i 1} { $i <= 8} {incr i} {
highlight_square $mode [expr $x+$i] [expr $y+$i]
highlight_square $mode [expr $x-$i] [expr $y-$i]
highlight_square $mode [expr $x+$i] [expr $y-$i]
highlight_square $mode [expr $x-$i] [expr $y+$i]
}
}
# 8-queens.tcl
proc disable_next {} {
.next config -state disabled
}
setup_display
# button for sending a 'next' message
button .next -text next -command {prolog_event next}
pack .next
# button for sending a 'stop' message
button .stop -text stop -command {prolog_event stop}
pack .stop
