Version 5 of N-puzzle
Updated 2005-12-12 01:38:58Keith 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.
JAG 11-Dec-2005: Keith, there seems to be a problem with the "Solver" as is depicted in this supposedly "solved" puzzle:
KPV oops, somehow the puzzle picked an insolvable starting position. I'm having trouble getting that routine working correctly--I might have to fall back on just simulating moving the tiles randomly 5,000 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 {[IsSolvable $b]} break
}
#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) ""
}
##+##########################################################################
#
# IsSolvable -- determines if a board is solvable by
# 1. moving hole to solution position
# 2. converting board position into a list
# 3. counting how many swaps needed to get to the solution
# 4. even number of swaps is solvable
#
proc IsSolvable {{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)
}
}
}
# Move hole to bottom right position
set hpos [lsearch $lboard 0]
while {$hpos < $S(n2) - $S(n)} { ;# Move hole to the bottom
set n [expr {$hpos + $S(n)}]
lset lboard $hpos [lindex $lboard $n]
lset lboard $n 0
set hpos $n
}
set lboard [concat [lreplace $lboard $hpos $hpos] 0] ;# Move hole to end
# Count swaps needed to get to solution position
set cnt 0
for {set i 0} {$i < $S(n2)-1} {incr i} {
set who [expr {$i+1}] ;# Who should be in position $i
set n [lsearch $lboard $who]
if {$n == $i} continue
lset lboard $n [lindex $lboard $i] ;# Swap who with piece at $i
lset lboard $i $who
incr cnt
}
return [expr {($cnt % 2) == 0}]
}
##+##########################################################################
#
# 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
Answer:
1. Move the pieces so that the blank or open space is in
the position it needs to be in for the solution.
2. Write down the state of the puzzle in a single line.
3. If any piece is out of position, write down another
state of the puzzle with that piece interchanged with the piece in its desired position, and repeat step 3.
4. Count how many interchanges were done in step 3.
If even, the puzzle is solvable, if odd, it is not.
Example puzzle:
1 8 2 6 s 3 4 7 5
Desired state:
1 2 3 4 5 6 7 8 s
Step 1.
1 8 2 6 7 3 4 s 5
1 8 2 6 7 3 4 5 s
Step 2.
1 8 2 6 7 3 4 5
Step 3.
1 2 8 6 7 3 4 5 1 2 3 6 7 8 4 5 1 2 3 4 7 8 6 5 1 2 3 4 5 8 6 7 1 2 3 4 5 6 8 7 1 2 3 4 5 6 7 8
Step 4.
6 interchanges were required, so the original puzzle is solvable.
OB Puzzle:
Prove that step 1 is never necessary in the 3x3 puzzle, but that it is necessary in general for the 4x4 puzzle.
#!/bin/sh # Restart with tcl: -*- mode: tcl; tab-width: 8; -*- \ exec wish $0 ${1+"$@"}
##+##########################################################################
#
# 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 {! [IsSolvable $b]} break
}
#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) ""
}
proc IsSolvable {{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)
}
}
}
# Move hole to bottom right position
set hpos [lsearch $lboard 0]
while {$hpos < $S(n2) - $S(n)} { ;# Move hole to the bottom
set n [expr {$hpos + $S(n)}]
lset lboard $hpos [lindex $lboard $n]
lset lboard $n 0
set hpos $n
}
set lboard [concat [lreplace $lboard $hpos $hpos] 0] ;# Move hole to end
# Count swaps needed to get to solution position
set cnt 0
for {set i 0} {$i < $S(n2)-1} {incr i} {
set who [expr {$i+1}] ;# Who should be in position $i
set n [lsearch $lboard $who]
if {$n == $i} continue
lset lboard $n [lindex $lboard $i] ;# Swap who with piece at $i
lset lboard $i $who
incr cnt
}
return [expr {($cnt % 2) == 0}]}
##+##########################################################################
#
# 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