Updated 2016-02-09 09:45:52 by HJG

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

Comments edit

(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.