## Summary

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 [L1 ]. 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.

Jeff Smith 2021-03-18 : Below is an online demo using CloudTk. This demo runs "The Classic 5 Puzzle" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + The-Classic-15-Puzzle.kit + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.

## Code

``` ##+##########################################################################
#
# 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

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)}]]
lassign \$DIRS(\$dir) dr dc

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
lassign \$B(r,\$val) row col
lassign \$B(r,0) hrow hcol
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)

lassign \$B(r,0) hrow hcol
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
lassign [eval TileXY \$B(r,\$val0)] x0 y0
lassign [eval TileXY \$B(r,\$val1)] x1 y1

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]
}
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} {
lassign \$B(r,\$i) row col
set HOLDER([expr {\$row*4 + \$col}]) \$i
}

MoveTo 1 0                                  ;# 1 into place
MoveTo 2 1                                  ;# 2 into place
Goal34                                      ;# 3,4 into place
MoveTo 5 4                                  ;# 5 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!
MakeDetour \$::detour3 7
MakeDetour \$::detour1 7
} elseif {\$hpos == 2 && \$HOLDER(6) == 4} {  ;# Darn!
MakeDetour \$::detour4 2
MakeDetour \$::detour1 7
} elseif {\$HOLDER(2) == 4} {                ;# Darn!
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!
MakeDetour \$::detour5 11
MakeDetour \$::detour2 11
} elseif {\$hpos == 6 && \$HOLDER(10) == 8} { ;# Darn!
MakeDetour \$::detour6 6
MakeDetour \$::detour2 11
} elseif {\$HOLDER(6) == 8} {                ;# Darn!
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} {
MakeDetour \$::detour7 9
MakeDetour \$::detour9 9
} elseif {\$hpos == 12 && \$HOLDER(13) == 9} {
MakeDetour \$::detour8 12
MakeDetour \$::detour9 9
} elseif {\$HOLDER(12) == 9} {
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} {
MakeDetour \$::detour10 10
MakeDetour \$::detour12 10
} elseif {\$hpos != 10 && \$HOLDER(14) == 10} {
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

# 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} {
}
}
##+##########################################################################
#
# AddMessage -- puts a message into move list to be displayed
#
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
lassign [list [expr {\$hpos / 4}] [expr {\$hpos & 3}]] hrow hcol
lassign [list [expr {\$ppos / 4}] [expr {\$ppos & 3}]] prow pcol
lassign [list [expr {\$tg / 4}] [expr {\$tg & 3}]] trow tcol

# 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
lassign [list [expr {\$move / 4}] [expr {\$move & 3}]] row col
Click \$::B(\$row,\$col) 1
update
after 200
}
set ::MOVES {}
set ::S(msg) "Done in \$cnt move[expr {\$cnt > 1 ? "s" : ""}]"
}

################################################################
################################################################

DoDisplay
NewBoard
return```

(DKF: The puzzle has been part of the standard Tk demos since before I started using Tcl.

KPV duh! Well, in my defense I can say that at least I'm not the only person to overlook the Tk demo version since Ideas for Projects in Tcl/Tk has it listed as a project to be done.)

HJG The 15-puzzle from the demo uses a collection of buttons that are moved around when clicked. It also uses place.

uniquename 2013jul29

The code above deserves an image to show the GUI that the code produces:

(Thanks to 'gnome-screenshot', 'mtpaint', and ImageMagick 'convert' on Linux for, respectively, capturing the screen to a PNG file, cropping the image, and converting the resulting PNG file to a JPEG file less than one-third the size of the PNG file. Thanks to FOSS developers everywhere --- including Linux kernel and Gnu developers. I used the 'mv' command and the ImageMagick 'identify' command to easily rename the cropped image file to contain the image dimensions in pixels.)

The code above may be of use to Tclers who need to put a grid on a canvas and to put text items in the boxes of the grid.

 Category Games Category Puzzles