Keith Vetter 2005-12-10 : After writing The Classic 15 Puzzle I decided to write a generalized version that could both play and solve any size board.
I also added some color visualization and made the solving code much cleaner. The only tricky part was generating a solvable random board--the algorithm of counting inversions only seems to work for even sized boards. I never could figure that out, so instead I just take the solution position and move the tiles randomly 5000 times.
##+##########################################################################
#
# N-Puzzle.tcl -- Plays and solve the classic N-puzzle
# by Keith Vetter, Dec 8 2005
#
# Solution algorithm taken from
# http://www.javaonthebrain.com/java/puzz15/technical.html
#
package require Tk
set S(n) 4
set font Helvetica
if {$tcl_platform(platform) eq "windows"} { set font {Comic Sans MS}}
font create numfont -family $font -size 22 -weight bold
##+##########################################################################
#
# Init -- initializes everything to board size S(n)
#
proc Init {} {
global S roundDisp roundDx
set S(n1) [expr {$S(n) - 1}] ;# Handy constants
set S(n2) [expr {$S(n) * $S(n)}]
set S(sz) [font measure numfont "15 "] ;# Size of a cell
set S(w) [expr {$S(n)*$S(sz) + 1}] ;# Size of board
set S(title) "N-Puzzle"
set S(state) playing
set S(soln) {}
for {set i 1} {$i <= $S(n2)} {incr i} { lappend S(soln) [expr {$i%$S(n2)}]}
# roundDisp are the offsets walking around a given cell
set t [list -$S(n) [expr {-$S(n)+1}] 1 [expr {$S(n)+1}] $S(n) \
[expr {$S(n)-1}] -1 [expr {-$S(n)-1}]]
MakeArray roundDisp [concat $t $t $t $t]
MakeArray roundDx {0 1 1 1 0 -1 -1 -1 0 1 1 1 0 -1 -1 -1 0 1 1 1 0 -1 -1 -1 0}
}
##+##########################################################################
#
# Resize -- changes the size of the board
#
proc Resize {} {
global S
if {$S(state) eq "solving"} { ;# Are we currently solving???
set S(kill) 1
set S(next) resize
return
}
Init
DoDisplay
NewBoard
}
##+##########################################################################
#
# DoDisplay -- puts up our display
#
proc DoDisplay {} {
global S
if {[winfo exists .c]} {
.c delete all
.c config -width $S(w) -height $S(w)
return
}
bind all <Key-F2> {console show}
wm title . $S(title)
DoMenus
canvas .c -width $S(w) -height $S(w) -highlightthickness 0 -bg gray75
label .msg -textvariable S(msg) -bd 2 -relief ridge
.msg configure -font "[font actual [.msg cget -font]] -weight bold"
pack .c -side top -padx 5 -pady 5
pack .msg -side top -fill x
}
##+##########################################################################
#
# DoMenus -- aren't installing menus really verbose and clunky?
#
proc DoMenus {} {
option add *Menu.tearOff 0
menu .menu
. config -menu .menu
menu .menu.game
.menu add cascade -label "Game" -menu .menu.game
.menu.game add command -label "New Board" -command NewBoard
.menu.game add command -label "Solve" -command Solve
.menu.game add separator
set m .menu.game.size
menu $m
.menu.game add cascade -label "Board Size" -menu $m
foreach n {2 3 4 5 6 7 8 9 10} {
$m add radio -label "${n}x$n" -variable S(n) -value $n -command Resize
}
.menu.game add separator
.menu.game add command -label "About" -command About
.menu.game add command -label "Exit" -command exit
}
##+##########################################################################
#
# Draws the board in array B
#
proc DrawNewBoard {} {
global B
.c delete all
for {set row 0} {$row < $::S(n)} {incr row} {
for {set col 0} {$col < $::S(n)} {incr col} {
set r [TileRect $row $col]
set xy [TileXY $row $col]
set val $B($row,$col)
set tag "tile$val"
set tag2 "cell$val"
if {$B($row,$col) == 0} {
.c create rect $r -width 1 -fill gray75 -tag $tag
continue
}
.c create rect $r -width 1 -fill white -tag [list tile $tag $tag2]
.c create text $xy -text $val -font numfont -tag $tag
.c bind $tag <1> [list Click $val]
}
}
}
##+##########################################################################
#
# NewBoard -- creates a new board in B then draws it
#
proc NewBoard {} {
global B S
if {$S(state) eq "solving"} {
set S(kill) 1
set S(next) "new"
return
}
;#while {1} {
;# set b [Shuffle $S(soln)] ;# Pick a random board
;# if {[Parity $b] == 0} break ;# Is it legal?
;#}
set b [ScrambleBoard]
set idx -1
for {set row 0} {$row < $S(n)} {incr row} {
for {set col 0} {$col < $S(n)} {incr col} {
set val [lindex $b [incr idx]]
set B($row,$col) $val
set B(r,$val) [list $row $col]
}
}
DrawNewBoard
set S(state) playing
set S(msg) ""
}
##+##########################################################################
#
# Creates a legal random board. To insure legality, it simulates
# moving the tiles MAX times.
#
proc ScrambleBoard {{max 5000}} {
array set DIRS {up {-1 0} down {1 0} left {0 -1} right {0 1}}
set b $::S(soln)
for {set i 0} {$i < $max} {incr i} {
set idx0 [lsearch $b 0] ;# Find the hole
set r0 [expr {$idx0 / $::S(n)}]
set c0 [expr {$idx0 - $::S(n)*$r0}]
while {1} {
set dir [lindex {up down left right} [expr {int(rand()*4)}]]
foreach {dr dc} $DIRS($dir) break
set r1 [expr {$r0 + $dr}]
set c1 [expr {$c0 + $dc}]
if {$r1 >= 0 && $r1 < $::S(n) && $c1 >= 0 && $c1 < $::S(n)} break
}
set idx1 [expr {$r1*$::S(n) + $c1}]
# Swap idx0 and idx1 in the board
set temp [lindex $b $idx0]
lset b $idx0 [lindex $b $idx1]
lset b $idx1 $temp
}
return $b
}
##+##########################################################################
#
# Parity -- returns the parity of the board. Parity is computed from the
# sum of the number of inversions plus the row the hole is in (base 1)
# Legal boards have parity of 0.
#
# Seems not to work for odd sized boards :(
#
proc Parity {{lboard {}}} {
global B S
if {$lboard eq {}} { ;# Turn board into a list
set lboard {}
for {set row 0} {$row < $S(n)} {incr row} {
for {set col 0} {$col < $S(n)} {incr col} {
lappend lboard $B($row,$col)
}
}
}
set hole [lsearch $lboard "0"] ;# Where the hole is
set lboard [lreplace $lboard $hole $hole] ;# Ignore hole in inversions
# Count inversions in this list
set cnt 0
for {set i 1} {$i < [llength $lboard]} {incr i} {
set elem [lindex $lboard $i]
for {set j 0} {$j < $i} {incr j} {
if {[lindex $lboard $j] > $elem} {incr cnt}
}
}
# Add in row the hole is in (base ($S(n)-1)%2)
set row [expr {$hole / $S(n)}]
incr cnt [expr {($hole / $S(n)) + $S(n1) % 2}]
set parity [expr {$cnt % 2}]
return $parity
}
##+##########################################################################
#
# Shuffle -- shuffles a list
#
proc Shuffle {llist} {
set len [llength $llist]
set len2 $len
for {set i 0} {$i < $len-1} {incr i} {
set n [expr {int($i + $len2 * rand())}]
incr len2 -1
# Swap elements at i & n
set temp [lindex $llist $i]
lset llist $i [lindex $llist $n]
lset llist $n $temp
}
return $llist
}
##+##########################################################################
#
# Moves tiles in response to clicks on the board.
#
proc Click {val {force 0}} {
global B
if {! $force && $::S(state) ne "playing"} return
foreach {row col} $B(r,$val) break
foreach {hrow hcol} $B(r,0) break
set dr [expr {$hrow-$row}]
set dc [expr {$hcol-$col}]
if {$dr != 0 && $dc != 0} return ;# Diagonal move attempt
if {$dr == 0 && $dc == 0} return ;# NOP move attempt
set adr [expr {$dr == 0 ? 0 : $dr/abs($dr)}];# Sign of dr
set adc [expr {$dc == 0 ? 0 : $dc/abs($dc)}]
set len [expr {abs($dr) + abs($dc)}] ;# How many tiles too move
for {set i 1} {$i <= $len} {incr i} {
set r1 [expr {$hrow - $i * $adr}]
set c1 [expr {$hcol - $i * $adc}]
set val $B($r1,$c1)
MoveTile $r1 $c1
UpdateBoard $val 0
}
if {[IsSolved]} Victory
}
##+##########################################################################
#
# MoveTile -- updates data structures for moving a tile
#
proc MoveTile {row col} {
global B
set val $B($row,$col)
foreach {hrow hcol} $B(r,0) break
set B($hrow,$hcol) $B($row,$col) ;# Hole get tile's value
set B($row,$col) 0 ;# Tile is now hole
set B(r,$val) [list $hrow $hcol] ;# Reverse indices
set B(r,0) [list $row $col]
}
##+##########################################################################
#
# UpdateBoard -- updates board to reflect moved tile
#
proc UpdateBoard {val0 val1} {
global B
;# NB. the tiles are ALREADY swapped in B
foreach {x0 y0} [eval TileXY $B(r,$val0)] break
foreach {x1 y1} [eval TileXY $B(r,$val1)] break
set dx [expr {$x1 - $x0}]
set dy [expr {$y1 - $y0}]
.c move tile$val1 $dx $dy
.c move tile$val0 [expr {-$dx}] [expr {-$dy}]
}
##+##########################################################################
#
# Returns TRUE if B is solved
#
proc IsSolved {} {
global B S
set idx 0
for {set row 0} {$row < $S(n)} {incr row} {
for {set col 0} {$col < $S(n)} {incr col} {
if {[incr idx] != $B($row,$col)} { ;# Always fails for the hole
return [expr {$idx == $S(n2)}]
}
}
}
return 0 ;# Should never get here
}
##+##########################################################################
#
# Shows that you've won
#
proc Victory {} {
.c itemconfig tile -fill magenta
set ::S(state) solved
}
##+##########################################################################
#
# Returns x,y of the center of tile at row,col
#
proc TileXY {row col} {
set x [expr {$col * $::S(sz) + $::S(sz)/2}]
set y [expr {$row * $::S(sz) + $::S(sz)/2}]
return [list $x $y]
}
##+##########################################################################
#
# Returns rectangle of tile at row,col
#
proc TileRect {row col} {
set x0 [expr {$col * $::S(sz)}]
set y0 [expr {$row * $::S(sz)}]
set x1 [expr {$x0 + $::S(sz)}]
set y1 [expr {$y0 + $::S(sz)}]
return [list $x0 $y0 $x1 $y1]
}
proc About {} {
set msg "N-Puzzle\nby Keith Vetter, December 2005\n\n"
append msg "Lets you create and try to solve the\n"
append msg "classic N-Puzzle. If you have trouble,\n"
append msg "just press the Solve button to see it done."
tk_messageBox -title "About N-Puzzle" -message $msg
}
################################################################
################################################################
#
# Solution code below. Generalized from http://www.javaonthebrain.com
#
proc Solve {} {
global S B MOVES HOLDER
if {$S(state) eq "solving"} { ;# Are we currently solving
set S(kill) 1 ;# Then stop
set S(next) ""
return
}
if {[IsSolved]} { ;# Already solved???
set S(msg) "Already solved"
Victory
return
}
set S(state) solving
set MOVES {}
unset -nocomplain HOLDER
for {set i 0} {$i < $S(n2)} {incr i} {
foreach {row col} $B(r,$i) break
set HOLDER([expr {$row*$S(n) + $col}]) $i
}
for {set row 0} {$row < $S(n)-2} {incr row} {
SolveRow $row
}
SolveLast2Rows
DoMoves
}
##+##########################################################################
#
# SolveRow -- solves any row but the bottom 2. Columns 0 - n-2 are easy,
# the last tow first go vertical then slip right in.
#
proc SolveRow {row} {
global S HOLDER
for {set col 0} {$col < $S(n)-2} {incr col} { ;# The easy column
set cell [expr {$row * $S(n) + $col}]
set who [expr {$cell + 1}]
AddMessage msg "Putting $who in place"
AddMessage start $who
MoveTo $who $cell
AddMessage done $who
}
set who [expr {$row * $S(n) + $S(n) - 1}]
set who2 [expr {$who + 1}]
set cell00 [expr {$row*$S(n) + $S(n) - 2}]
set cell01 [expr {$row*$S(n) + $S(n) - 1}]
set cell10 [expr {$row*$S(n) + 2*$S(n) - 2}]
set cell11 [expr {$row*$S(n) + 2*$S(n) - 1}]
if {$HOLDER($cell00) == $who && $HOLDER($cell01) == $who2} {
AddMessage done $who
AddMessage done $who2
set HOLDER($cell00) -1
set HOLDER($cell01) -1
return
}
AddMessage msg "Putting $who,$who2 in place"
AddMessage start $who
AddMessage start $who2
MoveTo $who $cell01
set hpos [Locate 0]
# Check where $who2 is
if {$HOLDER($cell00) == $who2 && $hpos == $cell11} {
AddMessage msg "Darn! $who2 needs a detour"
MakeDetour {l u r d}
MakeDetour {d l u r d l u r u l d r d}
} elseif {$HOLDER($cell10) == $who2 && $hpos == $cell00} {
AddMessage msg "Darn! $who2 needs a detour"
MakeDetour {r d}
MakeDetour {d l u r d l u r u l d r d}
} elseif {$HOLDER($cell00) == $who2} {
AddMessage msg "Darn! $who2 needs a detour"
MoveTo $who2 $cell10
MakeDetour {r d}
MakeDetour {d l u r d l u r u l d r d}
} else {
MoveTo $who2 $cell11
}
# Now who is in cell01; who2 in cell11
set HOLDER($cell01) $who ;# Unlock this piece
set HOLDER($cell11) -1
MoveTo $who $cell00
AddMessage done $who
set HOLDER($cell11) $who2 ;# Unlock this piece
MoveTo $who2 $cell01
AddMessage done $who2
}
##+##########################################################################
#
# SolveLast2Row -- like SolveRow but works horizontally
#
proc SolveLast2Rows {} {
global S HOLDER
set row [expr {$S(n) - 2}]
for {set col 0} {$col < $S(n)-2} {incr col} {
set who [expr {$row * $S(n) + $S(n) + $col + 1}]
set who2 [expr {$row * $S(n) + $col + 1}]
set cell00 [expr {$row * $S(n) + $col}]
set cell01 [expr {$row * $S(n) + $col + 1}]
set cell10 [expr {$row * $S(n) + $S(n) + $col}]
set cell11 [expr {$row * $S(n) + $S(n) + $col + 1}]
if {$HOLDER($cell10) == $who && $HOLDER($cell00) == $who2} {
AddMessage done $who
AddMessage done $who2
set HOLDER($cell10) -1
set HOLDER($cell00) -1
continue
}
AddMessage msg "Putting $who,$who2 in place"
AddMessage start $who
AddMessage start $who2
MoveTo $who $cell00
set hpos [Locate 0]
# Check where $who2 is
if {$HOLDER($cell10) == $who2 && $hpos == $cell01} {
AddMessage msg "Darn! $who2 needs a detour"
MakeDetour {d l u r}
MakeDetour {r d l u r d l u l d r u r}
} elseif {$HOLDER($cell11) == $who2 && $hpos == $cell10} {
AddMessage msg "Darn! $who2 needs a detour"
MakeDetour {u r}
MakeDetour {r d l u r d l u l d r u r}
} elseif {$HOLDER($cell10) == $who2} {
AddMessage msg "Darn! $who2 needs a detour"
MoveTo $who2 $cell11
MakeDetour {u r}
MakeDetour {r d l u r d l u l d r u r}
} else {
MoveTo $who2 $cell01
}
set HOLDER($cell00) $who
set HOLDER($cell01) -1
MoveTo $who $cell10
AddMessage done $who
set HOLDER($cell01) $who2
MoveTo $who2 $cell00
AddMessage done $who2
}
# Spin the last 3 pieces into place
set who00 [expr {$S(n2) - $S(n) - 1}]
set cell00 [expr {$who00 - 1}]
set who01 [expr {$S(n2) - $S(n)}]
set cell01 [expr {$who01 - 1}]
set who10 [expr {$S(n2) - 1}]
set cell10 [expr {$who10 - 1}]
AddMessage msg "Spinning last 3 pieces"
AddMessage start $who00
AddMessage start $who01
AddMessage start $who10
MoveTo $who00 $cell00
MoveTo $who01 $cell01
MoveTo $who10 $cell10
}
##+##########################################################################
#
# MakeDetour -- follows a list of u,d,r&l
#
proc MakeDetour {dirs} {
global S MOVES HOLDER
array set DIRS [list "l" -1 "r" 1 "d" $S(n) "u" "-$S(n)"]
set hpos [Locate 0]
foreach dir $dirs {
set to [expr {$hpos + $DIRS($dir)}]
set HOLDER($hpos) $HOLDER($to)
set HOLDER($to) 0
set hpos $to
lappend MOVES $to
}
return $MOVES
}
##+##########################################################################
#
# AddMessage -- puts a message into move list to be displayed
#
proc AddMessage {type what} {
lappend ::MOVES [list $type $what]
}
##+##########################################################################
#
# MoveTo -- Moves "piece" to position "to"
#
proc MoveTo {piece to} {
global HOLDER MOVES
set ppath [GetPath $piece $to]
set ppos [Locate $piece]
set HOLDER($ppos) -1
foreach tg $ppath {
MoveHole $tg $ppos ;# Get the hole where we want it
lappend MOVES $ppos ;# Move target into hole
set HOLDER($ppos) 0 ;# Update data structures
set HOLDER($tg) -1
set ppos $tg
}
return $MOVES
}
##+##########################################################################
#
# GetPath -- gets path that "piece" will take to get to "to". How it completes
# this path is somebody elses problem.
#
proc GetPath {piece to} {
set ppath {}
set hpos [Locate $piece]
while {($hpos % $::S(n)) < ($to % $::S(n))} { ;# Go right if we need to
lappend ppath [incr hpos]
}
while {($hpos % $::S(n)) > ($to % $::S(n))} { ;# Go left if we need to
lappend ppath [incr hpos -1]
}
while {$hpos > $to} { ;# Get up if we need to
lappend ppath [incr hpos -$::S(n)]
}
while {$hpos < $to} { ;# Get up if we need to
lappend ppath [incr hpos $::S(n)]
}
return $ppath
}
##+##########################################################################
#
# MoveHole -- the guts of the solution. Figures out how to get the hole to
# the target position next to ppos without disturbing already solved tiles.
#
proc MoveHole {tg ppos} {
global S HOLDER MOVES
global roundDisp roundDx
set hpos [Locate 0] ;# Find the hole
foreach {hrow hcol} [list [expr {$hpos/$S(n)}] [expr {$hpos % $S(n)}]] break
foreach {prow pcol} [list [expr {$ppos/$S(n)}] [expr {$ppos % $S(n)}]] break
foreach {trow tcol} [list [expr {$tg / $S(n)}] [expr {$tg % $S(n)}]] break
# Get in neighborhood of target
while {abs($hcol - $pcol) > 1 || abs($hrow - $prow) > 1} {
if {$hcol < $tcol && $HOLDER([expr {$hpos+1}]) > 0} {
#puts "go right"
set k [expr {$hpos + 1}]
incr hcol
} elseif {$hcol > $tcol && $HOLDER([expr {$hpos-1}]) > 0} {
#puts "go left"
set k [expr {$hpos - 1}]
incr hcol -1
} elseif {$hrow < $trow && $HOLDER([expr {$hpos+$S(n)}]) > 0} {
#puts "go down"
set k [expr {$hpos + $S(n)}]
incr hrow
} else {
#puts "go up"
set k [expr {$hpos - $S(n)}]
incr hrow -1
}
lappend MOVES $k
set HOLDER($hpos) $HOLDER($k)
set HOLDER($k) 0
set hpos $k
}
# Now we're 1 away from target. Find shortest path to target
if {$hpos == $tg} return ;# Did we get lucky?
# Locate where hpos is on perimeter of ppos
for {set j 8} {$hpos != $ppos + $roundDisp($j)} {incr j} {}
# Try going clockwise
set posCount 0
set k $j
while {$ppos + $roundDisp($k) != $tg} {
incr k
set to [expr {$ppos + $roundDisp($k)}]
if {$to >= 0 && $to < $S(n2) && $pcol+$roundDx($k) < $S(n) &&
$pcol+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
incr posCount
} else {
incr posCount 50
}
}
# Try going counter-clockwise
set negCount 0
set k $j
while {$ppos+$roundDisp($k) != $tg} {
incr k -1
set to [expr {$ppos + $roundDisp($k)}]
if {$to >= 0 && $to < $S(n2) && $pcol+$roundDx($k) < $S(n) &&
$pcol+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
incr negCount
} else {
incr negCount 50
}
}
# Pick optimal direction and do the moves
set dir [expr {$posCount <= $negCount ? 1 : -1}]
while {$hpos != $tg} {
incr j $dir
set k [expr {$ppos + $roundDisp($j)}]
lappend MOVES $k
set HOLDER($hpos) $HOLDER($k)
set HOLDER($k) 0
set hpos $k
}
}
##+##########################################################################
#
# Locate -- returns cell in which a given piece is located
#
proc Locate {num} {
for {set i 0} {$num != $::HOLDER($i)} {incr i} {}
return $i
}
##+##########################################################################
#
# DoMoves -- walks our move list and visually does each move
#
proc DoMoves {} {
global S B MOVES
set S(kill) 0
set S(next) ""
set cnt 0
foreach move $MOVES {
if {$S(kill)} break
if {[llength $move] > 1} { ;# Not a move
foreach {type what} $move break
if {$type eq "done"} {
.c itemconfig cell$what -fill green
} elseif {$type eq "start"} {
.c itemconfig cell$what -fill cyan
} else {
set S(msg) $what
}
continue
}
incr cnt
foreach {row col} [list [expr {$move/$S(n)}] [expr {$move%$S(n)}]] break
Click $B($row,$col) 1
update
after 200
}
set S(state) playing
if {$S(kill)} {
.c itemconfig tile -fill white
set S(msg) "stopped"
if {$S(next) eq "resize"} Resize
if {$S(next) eq "new"} NewBoard
} else {
set MOVES {}
set S(msg) "Done in $cnt move[expr {$cnt > 1 ? "s" : ""}]"
}
}
##+##########################################################################
#
# MakeArray -- turns a list into an array--easier access than lindex
#
proc MakeArray {_var values} {
upvar $_var var
set idx -1
foreach v $values {
set var([incr idx]) $v
}
}
################################################################
################################################################
Init
DoDisplay
NewBoard
return