**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 [http://www.javaonthebrain.com/java/puzz15/technical.html]. 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** ---- ======tcl ##+########################################################################## # # 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 {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 ====== ---- **Comments** ''([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: [vetter_15puzzle_wiki15067_screenshot_208x291.jpg] (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. <> Games | Puzzles