Summary edit
Keith Vetter 2005-12-07 : I was surprised that no one had created page for the classic 15 puzzle--the one where you slide tiles numbered 1-15 on a 4x4 grid trying to get them in order.I wasn't content to just make the puzzle, I also wanted to write a solver-- actually I wrote two solvers (but only posted one of them). The first solver did a BFS to find the optimal solution, but this can't handle solutions longer than about 15 moves. I was able to up that to about 30 moves using retrograde analysis.The second solver, which I included, uses a algorithm that I found at [1]. The algorithm is easy for a human to follow, but a bit tricky to program. Alas, once you know the trick, it's pretty boring to play.KPV I generalized this code in N-Puzzle to work with any size board.
Code edit
##+##########################################################################
#
# 15.tcl -- Plays and solve the classic 15 puzzle
# by Keith Vetter, Dec 5 2005
#
# Solution algorithm taken from
# http://www.javaonthebrain.com/java/puzz15/technical.html
#
package require Tk
if {![catch {package require tile} version]} {
if {$version >= 0.5} {
catch {namespace import -force ::ttk::button}
}
}
set S(font) Helvetica
if {$tcl_platform(platform) eq "windows"} { set S(font) {Comic Sans MS}}
font create numfont -family $::S(font) -size 22 -weight bold
set S(sz) [font measure numfont "15 "]
set S(w) [expr {4*$S(sz) + 1}]
set S(state) playing
set S(soln) {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 0}
##+##########################################################################
#
# DoDisplay -- puts up our display
#
proc DoDisplay {} {
global S
bind all <Key-F2> {console show}
wm title . "15 Puzzle"
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"
option add *font [.msg cget -font]
frame .buttons -bd 2 -relief ridge -pady 5
button .new -text "New Board" -command NewBoard
#style default My.TCheckbutton -bd 2 -relief raised
#::ttk::checkbutton .solve -text " Solve " -variable S(solve) -style My.TCheckbutton
button .solve -text "Solve" -command Solve
button .about -text "About" -command About
pack .c -side top -padx 5 -pady 5
pack .msg -side top -fill x
pack .buttons -side top -fill x
#pack .new .solve -in .buttons -side left -expand 1 -pady 10 -padx 10 -fill y
grid x .new x .solve x -in .buttons -sticky ew -row 0
grid x x x .about x -in .buttons -sticky ew -row 2
grid rowconfigure .buttons 1 -minsize 5
grid columnconfigure .buttons {1 3} -uniform a
grid columnconfigure .buttons {0 2 4} -weight 1
}
##+##########################################################################
#
# Draws the board in B
#
proc DrawNewBoard {} {
global B
.c delete all
for {set row 0} {$row < 4} {incr row} {
for {set col 0} {$col < 4} {incr col} {
set r [TileRect $row $col]
set xy [TileXY $row $col]
set val $B($row,$col)
set tag "tile$val"
if {$B($row,$col) == 0} {
.c create rect $r -width 1 -fill gray75 -tag $tag
} else {
.c create rect $r -width 1 -fill white -tag [list tile $tag]
.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 {{n 500}} {
global B S
set l [ScrambleBoard $n]
for {set row 0} {$row < 4} {incr row} {
for {set col 0} {$col < 4} {incr col} {
set n [expr {int(rand() * [llength $l])}]
set n 0
set val [lindex $l $n]
set B($row,$col) $val
set B(r,$val) [list $row $col]
set l [lreplace $l $n $n]
}
}
DrawNewBoard
set S(state) playing
.solve config -state normal
}
##+##########################################################################
#
# Creates a legal random board. To insure legality, it simulates
# moving the tiles MAX times.
#
proc ScrambleBoard {{max 300}} {
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]
set r0 [expr {$idx0 / 4}]
set c0 [expr {$idx0 - 4*$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 <= 3 && $c1 >= 0 && $c1 <= 3} break
}
set idx1 [expr {$r1*4 + $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
}
##+##########################################################################
#
# 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
set idx 0
for {set row 0} {$row < 4} {incr row} {
for {set col 0} {$col < 4} {incr col} {
if {[incr idx] != $B($row,$col)} { ;# Always fails for the hole
return [expr {$idx == 16}]
}
}
}
return 0 ;# Should never get here
}
##+##########################################################################
#
# Shows that you've won
#
proc Victory {} {
.c itemconfig tile -fill cyan
set ::S(state) solved
}
proc DumpBoard {b} {
set idx -1
for {set row 0} {$row < 4} {incr row} {
for {set col 0} {$col < 4} {incr col} {
set c "0x[string index $b [incr idx]]"
set num [expr {$c eq "0x-" ? "" : $c}]
puts -nonewline [format "%3s" $num]
}
puts ""
}
}
##+##########################################################################
#
# 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 "15 Puzzle\nby Keith Vetter, December 2005\n\n"
append msg "Let's you create and try to solve the\n"
append msg "classic 15 puzzle. If you have trouble,\n"
append msg "just press the Solve button to see it done."
tk_messageBox -title "About 15 Puzzle" -message $msg
}
################################################################
################################################################
#
# Solution code below. Cribbed from http://www.javaonthebrain.com
#
proc Solve {} {
global B MOVES HOLDER
set ::S(state) solving
.new config -state disabled
.solve config -state disabled
set MOVES {}
unset -nocomplain HOLDER
for {set i 0} {$i < 16} {incr i} {
foreach {row col} $B(r,$i) break
set HOLDER([expr {$row*4 + $col}]) $i
}
AddMessage "Putting 1 into place"
MoveTo 1 0 ;# 1 into place
AddMessage "Putting 2 into place"
MoveTo 2 1 ;# 2 into place
Goal34 ;# 3,4 into place
AddMessage "Putting 5 into place"
MoveTo 5 4 ;# 5 into place
AddMessage "Putting 6 into place"
MoveTo 6 5 ;# 6 into place
Goal78 ;# 7,8 into place
Goal9,13 ;# 13,9 into place
Goal10,14 ;# 14,10 into place
Goal15
DoMoves
.new config -state normal
}
proc MakeArray {_var values} {
upvar $_var var
set idx -1
foreach v $values {
set var([incr idx]) $v
}
}
MakeArray roundDisp {-4 -3 1 5 4 3 -1 -5 -4 -3 1 5 4 3 -1 -5 -4 -3 1 5 4 3 -1 -5 -4}
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}
set detour1 {11 10 6 7 11 10 6 7 3 2 6 7 11}
set detour2 {15 14 10 11 15 14 10 11 7 6 10 11 15}
set detour3 {6 2 3 7}
set detour4 {3 7}
set detour5 {10 6 7 11}
set detour6 {7 11}
set detour7 {13 12 8 9}
set detour8 {8 9}
set detour9 {10 14 13 9 10 14 13 9 8 12 13 9 10}
set detour10 {14 13 9 10}
set detour11 {9 10}
set detour12 {11 15 14 10 11 15 14 10 9 13 14 10 11}
set roundAbout {11 10 14 15}
proc Goal34 {} {
global HOLDER
if {$HOLDER(2) == 3 && $HOLDER(3) == 4} { ;# Already in place
set HOLDER(2) -1
set HOLDER(3) -1
return
}
AddMessage "Putting 3 & 4 into place"
MoveTo 3 3
set hpos [Locate 0]
if {$hpos == 7 && $HOLDER(2) == 4} { ;# Darn!
AddMessage "Darn! 4 badly placed, need detour"
MakeDetour $::detour3 7
MakeDetour $::detour1 7
} elseif {$hpos == 2 && $HOLDER(6) == 4} { ;# Darn!
AddMessage "Darn! 4 badly placed, need detour"
MakeDetour $::detour4 2
MakeDetour $::detour1 7
} elseif {$HOLDER(2) == 4} { ;# Darn!
AddMessage "Darn! 4 badly placed, need detour"
MoveTo 4 6
MakeDetour $::detour4 2
MakeDetour $::detour1 7
} else {
MoveTo 4 7
}
# Now walk 3,4 into position
set HOLDER(3) 3 ;# Unlock this piece
set HOLDER(7) -1
MoveTo 3 2
set HOLDER(7) 4 ;# Unlock this piece
MoveTo 4 3
}
proc Goal78 {} {
global HOLDER
if {$HOLDER(6) == 7 && $HOLDER(7) == 8} {
set HOLDER(6) -1
set HOLDER(7) -1
return
}
AddMessage "Putting 7 & 8 into place"
MoveTo 7 7
set hpos [Locate 0]
if {$hpos == 11 && $HOLDER(6) == 8} { ;# Darn!
AddMessage "Darn! 8 badly placed, need detour"
MakeDetour $::detour5 11
MakeDetour $::detour2 11
} elseif {$hpos == 6 && $HOLDER(10) == 8} { ;# Darn!
AddMessage "Darn! 8 badly placed, need detour"
MakeDetour $::detour6 6
MakeDetour $::detour2 11
} elseif {$HOLDER(6) == 8} { ;# Darn!
AddMessage "Darn! 8 badly placed, need detour"
MoveTo 8 10
MakeDetour $::detour6 6
MakeDetour $::detour2 11
} else {
MoveTo 8 11
}
set HOLDER(7) 7 ;# Unlock this piece
set HOLDER(11) -1
MoveTo 7 6
set HOLDER(11) 8 ;# Unlock this piece
MoveTo 8 7
}
proc Goal9,13 {} {
global HOLDER
if {$HOLDER(8) == 9 && $HOLDER(12) == 13} {
set HOLDER(8) -1
set HOLDER(12) -1
return
}
AddMessage "Putting 9 & 13 into place"
MoveTo 13 8
set hpos [Locate 0]
if {$hpos == 9 && $HOLDER(12) == 9} {
AddMessage "Darn! 9 badly placed, need detour"
MakeDetour $::detour7 9
MakeDetour $::detour9 9
} elseif {$hpos == 12 && $HOLDER(13) == 9} {
AddMessage "Darn! 9 badly placed, need detour"
MakeDetour $::detour8 12
MakeDetour $::detour9 9
} elseif {$HOLDER(12) == 9} {
AddMessage "Darn! 9 badly placed, need detour"
MoveTo 9 13
MakeDetour $::detour8 12
MakeDetour $::detour9 9
} else {
MoveTo 9 9
}
set HOLDER(8) 13
set HOLDER(9) -1
MoveTo 13 12
set HOLDER(9) 9
MoveTo 9 8
}
proc Goal10,14 {} { ;# 10,14
global HOLDER
if {$HOLDER(9) == 10 && $HOLDER(13) == 14} {
set HOLDER(9) -1
set HOLDER(13) -1
return
}
AddMessage "Putting 10 & 14 into place"
MoveTo 14 9
set hpos [Locate 0]
if {$hpos == 10 && $HOLDER(13) == 10} {
AddMessage "Darn! 10 badly placed, need detour"
MakeDetour $::detour10 10
MakeDetour $::detour12 10
} elseif {$hpos != 10 && $HOLDER(14) == 10} {
AddMessage "Darn! 10 badly placed, need detour"
MakeDetour $::detour11 13
MakeDetour $::detour12 10
} else {
MoveTo 10 10
}
set HOLDER(9) 14
set HOLDER(10) -1
MoveTo 14 13
set HOLDER(10) 10
MoveTo 10 9
}
proc Goal15 {} {
global HOLDER MOVES
AddMessage "Last little bit"
# Get hole into corner
while {$HOLDER(15) != 0} {
if {$HOLDER(10) == 0} {
lappend MOVES 11
set HOLDER(10) $HOLDER(11)
set HOLDER(11) 0
}
if {$HOLDER(11) == 0} {
lappend MOVES 15
set HOLDER(11) $HOLDER(15)
set HOLDER(15) 0
}
if {$HOLDER(14) == 0} {
lappend MOVES 15
set HOLDER(14) $HOLDER(15)
set HOLDER(15) 0
}
}
# Rotate until done
while {$HOLDER(14) != 15} {
MakeDetour $::roundAbout 15
}
}
##+##########################################################################
#
# AddMessage -- puts a message into move list to be displayed
#
proc AddMessage {msg} {
lappend ::MOVES $msg
}
##+##########################################################################
#
# 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 & 3) < ($to & 3)} { ;# Go right if we need to
lappend ppath [incr hpos]
}
while {($hpos & 3) > ($to & 3)} { ;# Go left if we need to
lappend ppath [incr hpos -1]
}
while {$hpos > $to} { ;# Get up if we need to
lappend ppath [incr hpos -4]
}
while {$hpos < $to} { ;# Get up if we need to
lappend ppath [incr hpos 4]
}
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 HOLDER MOVES
global roundDisp roundDx
set hpos [Locate 0] ;# Find the hole
foreach {hrow hcol} [list [expr {$hpos / 4}] [expr {$hpos & 3}]] break
foreach {prow pcol} [list [expr {$ppos / 4}] [expr {$ppos & 3}]] break
foreach {trow tcol} [list [expr {$tg / 4}] [expr {$tg & 3}]] break
# Get in neighborhood of target
while {abs($hcol - $pcol) > 1 || abs($hrow - $prow) > 1} {
if {$hcol < $tcol && $HOLDER([expr {$hpos+1}]) > 0} {
set k [expr {$hpos + 1}]
incr hcol
} elseif {$hcol > $tcol && $HOLDER([expr {$hpos-1}]) > 0} {
set k [expr {$hpos - 1}]
incr hcol -1
} elseif {$hrow < $trow && $HOLDER([expr {$hpos+4}]) > 0} {
set k [expr {$hpos + 4}]
incr hrow
} else {
set k [expr {$hpos - 4}]
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
set posCount 0
set negCount 0
set j 8
while {$hpos != $ppos + $roundDisp($j)} {
incr j
}
set k $j
while {$ppos + $roundDisp($k) != $tg} {
incr k
set to [expr {$ppos + $roundDisp($k)}]
if {$to >= 0 && $to < 16 && ($ppos&3)+$roundDx($k) < 4 &&
($ppos&3)+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
incr posCount
} else {
incr posCount 50
}
}
set k $j
while {$ppos+$roundDisp($k) != $tg} {
incr k -1
set to [expr {$ppos + $roundDisp($k)}]
if {$to >= 0 && $to < 16 && ($ppos&3)+$roundDx($k) < 4 &&
($ppos&3)+$roundDx($k) >= 0 && $HOLDER($to) > 0} {
incr negCount
} else {
incr negCount 50
}
}
set l [expr {$posCount <= $negCount ? 1 : -1}]
while {$hpos != $tg} {
incr j $l
set k [expr {$ppos + $roundDisp($j)}]
lappend MOVES $k
set HOLDER($hpos) $HOLDER($k)
set HOLDER($k) 0
set hpos $k
}
}
##+##########################################################################
#
# MakeDetour -- adds a canned set of moves to our move list
#
proc MakeDetour {mList hpos} {
global HOLDER MOVES
foreach to $mList {
set HOLDER($hpos) $HOLDER($to) ;# To goes into hole
set HOLDER($to) 0 ;# Mark new hole
set hpos $to
lappend MOVES $to
}
return $MOVES
}
##+##########################################################################
#
# 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 {} {
set cnt 0
foreach move $::MOVES {
if {! [string is integer $move]} { ;# Not a move, a message
set ::S(msg) $move
continue
}
incr cnt
foreach {row col} [list [expr {$move / 4}] [expr {$move & 3}]] break
Click $::B($row,$col) 1
update
after 200
}
set ::MOVES {}
set ::S(msg) "Done in $cnt move[expr {$cnt > 1 ? "s" : ""}]"
}
################################################################
################################################################
DoDisplay
NewBoard
return
