Eight Queens Problem

Introduction
Program 1
Program 2
Screenshots
...

Introduction

K L Prasad: As one of my initial attempts at TCL/TK programming, I have created the following code to solve the well known eight queens problem of chess visually.
Just in case somebody wants to know, the problem is to place eight queens on a chess board, so that no queen attacks others, but together they cover the entire board. It uses a simple back tracking algorithm and can compute all the solutions.

Suggestions and comments are welcome.

wdb Those who are new to this problem can try it online [L1 ] -- just play, no computer-based solution, and no Tcl/Tk but JavaScript, but funny nonetheless.

Program 1

#!/bin/sh
# the next restarts using wish \
exec wish "$0" "$@"

# Search Procedure
proc search {} {
   global board col lbltxt 
   set TRUE 1; set FALSE 0
   while 1 {
     if {$board($col) != 0} {
       set row [expr {9 - $board($col)}]
       .f2.btn$row$col configure -image empty
       # after 100; update <--- this is slow and unnecessary
     }
     incr board($col); 
     if {$board($col) > 8} {
       set board($col) 0; 
       if {$col > 1} {incr col -1; continue}
     }
     set row [expr {9 - $board($col)}]
     .f2.btn$row$col configure -image queen
     # after 100; update <-- see above
     set place $TRUE 
     for {set j 1} {$j < $col} {incr j} {
       if {$board($j) == $board($col)} {
         set row [expr {9 - $board($j)}]
         .f2.btn$row$j flash
         set place $FALSE
         break
       }
       set x [expr {$col - $j}]
       set y [expr {$board($col) - $board($j)}]
       if { ($x == $y) || ($x == -1*$y) } {
         set row [expr {9 - $board($j)}]
         .f2.btn$row$j flash  
         set place $FALSE
         break
       }
     }
     if {$place == $TRUE} {
       incr col
       if {$col > 8} { 
         if {[wm state .] != "normal"} {wm state . normal}; # restore the main window if required
         incr col -1; 
         set lbltxt "Solution Found"; update
         set ans [tk_messageBox -message "Solution found.\nSearch for another?" \
                                -type yesno -icon question]
         switch -- $ans {
           yes {}
           no  quit; # ask if the user wants to quit
         }
       }
     }
     set lbltxt "Searching for Solution"
     update ;# this update  (1 per loop) is enough, as the loop is short
   }
}

# Quit Procedure
proc quit {} {
   global lbltxt
   set lbltxt ""; update; # lbltxt made empty
   set ans [tk_messageBox -message "Really Quit?" -type yesno \
                          -default "no" -icon question]
   switch -- $ans {
     yes exit
     no  {}
   }
}
      
# Main Procedure  
set queendata "R0lGODlhKAAoAKEAAP8AAAAAAP///wAAACH5BAEAA
                AAALAAAAAAoACgAAALghI+py+0YwpsUxFgzw5pKxS
                VfZ1zgeJikFaZo2XYvvMyaHZere/Y7K1LxHjkaRCB
                4FTnCICqAfC6Zy+TRmsI6hyKtJXqc5cbJEVQb8Roh
                sbMZXIK7xGp3Fi1nqb8t98eu5wVFJohklVb2JZeGM
                /gGdgZp+GijyDSJGJX5BwgyGYdpWCYqsbmBqahJGn
                lIeorJKioL61ojmzmbi7sHk+v7u9oQC0yc5/l7kTx
                cu+GojAj9zFg5t1uWPKvsoXx70Z1cwQ0rrtnkIO39
                LR1eXEzd1Q787hIvP8+Cnp//w9+/UwAAOw=="
for {set i 1} {$i < 9} {incr i} {set board($i) 0}
set col 1
wm title . "Eight Queens Problem"
wm protocol . WM_DELETE_WINDOW {quit}
wm resizable . 0 0
image create photo queen -format GIF -data $queendata 
image create photo empty -format GIF -data $queendata
empty blank
set ht [image height queen]; set ht [expr {1.5 * $ht}]
set wd [image width queen];  set wd [expr {1.5 * $wd}]
set bgcolor(0) "green3"; set bgcolor(1) "yellow3"
set l 0
frame .f1 -relief groove -bd 3; pack .f1 -fill x
label .f1.lbl -textvariable lbltxt; pack .f1.lbl 
# set lbltxt "Searching for Solution" <---------- set only if start button is clicked
frame .f2 -relief groove -bd 3; pack .f2
for {set i 1} {$i < 9} {incr i} {
   for {set j 1} {$j < 9} {incr j} {
     button .f2.btn$i$j -image empty -height $ht -width $wd \
                        -bg $bgcolor($l) -activebackground "red" 
     grid .f2.btn$i$j -row $i -column $j
     set l [expr {1 - $l}]
   }
   set l [expr {1 - $l}] ;# could be done as [expr {!$l}]
}
frame .f3 -relief groove -bd 3; pack .f3
button .f3.start -text "Start" -command {set lbltxt "Searching for Solution"; search}
button .f3.stop -text "Stop" -command {quit}
pack .f3.start -side left; pack .f3.stop -after .f3.start

Michael Schlenker Nice toy. I added some comments, {} for the expr's and removed two unnecessary updates.

escargo It appears that the "Searching for Solution" label does not change state when no search is in progress. Perhaps it should be disabled until the start button is pressed. There are more than two states involved, really.

Also, I was surprised when the program exited after I declined to search for another solution. I had the program running behind others and when the dialog popped up I clicked the "No" and then the program exited before I could see the solution. Perhaps there should be separate exit button.

K L Prasad: Thanks for the suggestions and pointing out the problems. I also found a problem. When a solution is found, a message box pops up. At that time if the main window is in a minimized state, there is no way to look at the solution. I have made the necessary changes, which I hope solve the problems.

Program 2

K L Prasad: The above program has one problem. It uses buttons. In Linux when the mouse pointer is on a button, it is highlighted with active background color, which can be quite distracting. So I rewrote the program using canvas and properties.

#!/bin/sh
# the next restarts using wish \
exec wish "$0" "$@"

 # Search Procedure
 proc search {} {
   global board col lbltxt c rect ph ht yarr ymax sol fast
   set TRUE 1; set FALSE 0
   while 1 {
     incr board($col)
     if {$board($col) > 8} {
       set board($col) 0
       $c move $ph($col) 0 [expr $ymax-$yarr($col)]
       set yarr($col) $ymax
       if {$col > 1} {incr col -1; continue}
     }
     $c move $ph($col) 0 -$ht; set yarr($col) [expr $yarr($col)-$ht]
     set place $TRUE
     for {set j 1} {$j < $col} {incr j} {
       if {$board($j) == $board($col)} {
         set row [expr {9 - $board($j)}]
         flash $c $rect($j,$row)
         set place $FALSE
         break
       }
       set x [expr {$col - $j}]
       set y [expr {$board($col) - $board($j)}]
       if { ($x == $y) || ($x == -1*$y) } {
         set row [expr {9 - $board($j)}]
         flash $c $rect($j,$row)
         set place $FALSE
         break
       }
     }
     if {$place == $TRUE} {
       incr col
       if {$col > 8} {
         if {[wm state .] != "normal"} {wm state . normal}
         raise .
         incr col -1;
         incr sol  1;
         set lbltxt "Solution Found: $sol"; update
         set ans [tk_messageBox -title "Solution found" \
                                -message "Search for another?" \
                                -type yesno -icon question]
         switch -- $ans {
           yes {}
           no  quit
         }
       }
     }
     set lbltxt "Searching for Solution"
     after 25; update 
   }
 }

 # Flash Procedure
 proc flash {c r} {
   if $::fast {return}
   for {set k 0} {$k < 4} {incr k} {
     set fc [$c itemcget $r -fill]
     $c itemconfigure $r -fill "red"
     update idletasks
     after 25
     $c itemconfigure $r -fill $fc
     update idletasks
     after 25
   }
}
    
# Quit Procedure
proc quit {} {
   global lbltxt
   set lbltxt ""
   update
   set ans [tk_messageBox -title "Eight Queens" -message "Quit?" \
                          -type yesno -default "no" -icon question]
   switch -- $ans {
     yes exit
     no  {}
   }
}

# Main Procedure
set queendata "R0lGODlhKAAoAKEAAP8AAAAAAP///wAAACH5BAEAA
                AAALAAAAAAoACgAAALghI+py+0YwpsUxFgzw5pKxS
                VfZ1zgeJikFaZo2XYvvMyaHZere/Y7K1LxHjkaRCB
                4FTnCICqAfC6Zy+TRmsI6hyKtJXqc5cbJEVQb8Roh
                sbMZXIK7xGp3Fi1nqb8t98eu5wVFJohklVb2JZeGM
                /gGdgZp+GijyDSJGJX5BwgyGYdpWCYqsbmBqahJGn
                lIeorJKioL61ojmzmbi7sHk+v7u9oQC0yc5/l7kTx
                cu+GojAj9zFg5t1uWPKvsoXx70Z1cwQ0rrtnkIO39
                LR1eXEzd1Q787hIvP8+Cnp//w9+/UwAAOw=="
wm title . "Eight Queens Problem"
wm protocol . WM_DELETE_WINDOW {quit}
wm resizable . 0 0
image create photo queen -format GIF -data $queendata
set ht [image height queen]; set ht [expr {1.75 * $ht}]
set wd [image width queen];  set wd [expr {1.75 * $wd}]
set fillcolor(0) "green3"; set fillcolor(1) "yellow3"
set l 0
frame .f1 -relief groove -bd 3; pack .f1 -fill x
label .f1.lbl -textvariable lbltxt; pack .f1.lbl
frame .f2 -relief groove -bd 3; pack .f2
set c [canvas .f2.c -width [expr 8*$wd+2] -height [expr 8*$ht+2]]
pack $c
set w1 1; set w2 [expr $w1+$wd]; 
set x [expr 1+$wd/2]; set ymax [expr 1+$ht/2+8*$ht]
for {set i 1} {$i < 9} {incr i} {
   set h1 1; set h2 [expr $h1+$ht]
   for {set j 1} {$j < 9} {incr j} {
     set rect($i,$j) [$c create rectangle $w1 $h1 $w2 $h2 -fill $fillcolor($l)]
     set h1 $h2; set h2 [expr $h1+$ht]; set l [expr {!$l}]
   }
   set w1 $w2; set w2 [expr $w1+$wd]; set l [expr {!$l}] 
   set ph($i) [$c create image $x $ymax -image queen]; set x [expr $x+$wd]
   set board($i) 0; set yarr($i) $ymax
}
set col 1
set sol 0
frame       .f3 -relief groove -bd 3; pack .f3
button      .f3.start -text "Start" -command {set lbltxt "Searching for Solution"; search}
button      .f3.stop  -text "Stop"  -command {quit}
checkbutton .f3.fast  -text "Fast"  -variable fast
pack .f3.start .f3.stop .f3.fast -side left

Screenshots

Eight Queens Problem screen
gold added pix

...

KBK A very different approach to the problem is found over in the Solving cryptarithms page.
It lacks a GUI, but it demonstrates the use of a fairly general framework for backtracking search.

HJG Added a solution-counter, and a "Fast"-checkbox for skipping the flash-delay.