1. This needs a reset button, to get to the starting position if you have jammed yourself into a corner.
2. We might also wish to ask the referenced site to add a link to this implementation, with image. They already link to many other implementations.
3. These thousands of levels, do they use a common data format ? Something we can write a reader for ? Maybe some hardwired urls where to find them, with automatic download ?

##+##########################################################################
#
# Rush Hour -- a sliding block puzzle
# by Keith Vetter, September 2004
#
# http://www.puzzles.com/products/rushhour.htm
# gtlevel: http://alpha.luc.ac.be/Research/Algebra/Members/Gtlevel/gtlevel.html
#
# solver:
#   http://www.theiling.de/projects/rushhour.html
#   http://stackoverflow.com/questions/2877724/rush-hour-solving-the-game?rq=1

package require Tk

set L(0) {{v 2 3 2} {h 3 0 0} {h 3 1 0}}
set L(1) {{v 2 3 2} {h 3 0 0} {v 2 0 4} {v 3 1 5} {h 3 2 1} \
              {v 2 4 0} {h 3 5 1} {h 2 5 4}}
set L(2) {{v 2 3 2} {h 3 0 3} {h 3 2 2} {v 2 2 5} {v 2 3 3} {h 2 4 4}}
set L(3) {{v 2 4 2} {v 2 0 0} {v 2 0 1} {h 2 0 2} {h 2 0 4} {h 3 1 2} \
              {v 2 2 0} {h 2 2 1} {v 3 2 3} {h 2 3 4} {h 2 4 0} {h 3 5 3}}
set L(4) {{v 2 3 2} {v 3 0 3} {h 2 0 4} {h 3 2 0} {v 3 1 5} {v 2 3 0} \
              {h 2 3 3} {h 3 5 0}}
set L(5) {{v 2 2 2} {v 2 0 1} {h 2 0 2} {h 2 1 2} {v 2 0 4} {v 2 2 3} \
              {h 2 3 0} {h 2 3 4} {v 2 4 0} {h 2 4 2} {h 2 5 2} {v 2 4 5}}
set L(6) {{v 2 2 2} {v 2 1 0} {h 2 1 1} {h 2 1 3} {v 2 2 3} {v 3 2 4} \
              {h 2 3 0} {h 2 4 2}}
set L(7) {{v 2 3 2} {v 3 0 5} {h 3 2 0} {v 3 2 3} {h 2 3 0} {v 2 4 0} {h 3 5 1}}
set L(8) {{v 2 3 2} {v 2 0 0} {h 3 0 1} {v 2 0 4} {v 2 0 5} {h 2 1 2} \
              {v 3 2 3} {h 2 2 4} {h 2 3 0} {v 2 4 0} {v 2 4 1} {h 2 4 4} \
              {h 3 5 2}}
set L(9) {{v 2 4 2} {v 2 0 1} {h 3 0 3} {v 2 1 3} {v 3 1 4} {h 2 2 0} \
              {v 2 2 5} {v 3 3 0} {h 3 3 1} {h 2 4 3} {v 2 4 5} {h 2 5 3}}
set L(10) {{v 2 3 2} {v 3 0 0} {v 2 0 1} {h 3 0 2} {v 3 0 5} {v 2 1 3} \
               {h 2 2 1} {h 3 3 3} {v 2 4 0} {v 2 4 4} {h 2 5 2}}
set L(11) {{v 2 4 2} {v 2 0 0} {h 3 0 3} {v 2 1 3} {h 2 1 4} {h 2 2 4} \
               {h 3 3 0} {v 2 3 3} {v 2 3 4} {v 3 3 5} {h 2 4 0} {h 2 5 3}}
set L(12) {{v 2 4 2} {v 3 0 0} {h 3 0 2} {v 2 1 3} {h 2 2 1} {v 2 2 4} \
               {v 2 2 5} {h 2 3 0} {h 2 3 2} {v 2 4 3} {h 2 4 4} {h 2 5 4}}

proc Init {} {
    set ::G(ccnt) 0
    set ::G(banner) ""
    set ::G(banner_font) {Times 36 bold}
    set ::G(banner_width) 4
    set ::G(exit_font) {Helvetica 8 bold}
    set ::G(id_font) {Times 18 bold}
    array set ::B {w 6 h 6 exit,row 0 exit,col 2 m 20 m2 4 wall 20}
    set ::B(w2) [expr {$::B(w) / 2}]
    set ::B(h2) [expr {$::B(h) / 2}]

    wm title . "Rush Hour"
    ttk::frame .all
    ttk::frame .top -borderwidth 2 -relief raised
    ::ttk::style configure largeFont.TButton -font {Helvetica 18 bold}
    ::ttk::button .title -style largeFont.TButton -text "Rush Hour" -command Help

    canvas .c -width 400 -height 400 -highlightthickness 0 -borderwidth 0

    ttk::frame .bot -borderwidth 2 -relief ridge
    set ::B(lvls) {}
    for {set i 1} {$i <= 12} {incr i} {
        set lvl "Level $i "
        append lvl [expr {$i < 4 ? "Beginner" : $i < 7 ? "Intermediate" : \
                              $i < 10 ? "Advanced" : "Expert"}]
        lappend ::B(lvls) $lvl
    }

    tk_optionMenu .lvl ::G(who) {*}$::B(lvls)
    trace variable ::G(who) w ChangeLevel

    ttk::button .reset -text "Reset" -command LoadLevel
    ttk::button .next -text "Next Level" -command NextLevel
    ttk::checkbutton .solve -text Solve -command Solve -variable G(show,solution) ;#-style Toolbutton

    BuildSolutionWindow

    pack .all -side left -fill both -expand 1
    pack .top -in .all -side top -fill both
    pack .bot -in .all -side bottom -fill both
    pack .c -in .all -side top -fill both -expand 1

    pack .title -in .top -side left -expand 1 -pady 10
    #pack .lvl .reset .next -in .bot -side left -expand 1
    #pack .solve -in .bot -side right -padx 5 -fill both -expand 1
    grid .lvl .reset .next .solve -in .bot
    grid columnconfigure .bot all -weight 1
    bind .c <Configure> {ReCenter %W %h %w}
}
proc BuildSolutionWindow {} {
    set w .solution

    if {[lsearch [image names] ::img::chi] == -1} {
        image create bitmap ::img::chi -data {
            #define x_width 7
            #define x_height 7
            static char x_bits = {
                0x63, 0x77, 0x3e, 0x1c, 0x3e, 0x77, 0x63
            }
        }
    }

    ttk::frame $w
    ttk::label $w.title -text "Solution" -font {Helvetica 14 bold}
    ttk::scrollbar $w.sb -orient vertical -command [list $w.lb yview]
    listbox $w.lb -listvariable ::G(solution) -yscroll [list $w.sb set] \
        -exportselection 0
    button $w.close -image ::img::chi -command {.solve invoke}
    place forget $w.close
    place $w.close -relx 1 -rely 0 -x -3 -y 3 -anchor ne

    pack $w.title -side top
    pack $w.sb -side right -fill y
    pack $w.lb -side left -fill both -expand 1
}
proc ReCenter {W h w} {                   ;# Called by configure event
    set h2 [expr {$h / 2}]
    set w2 [expr {$w / 2}]
    $W config -scrollregion [list -$w2 -$h2 $w2 $h2]
    DrawBoard 1
}
proc ChangeLevel {var1 var2 op} {
    if {! [scan $::G(who) "Level %d" lvl]} return
    LoadLevel $lvl
}
proc NextLevel {} {
    global G B
    set n [lsearch $B(lvls) $G(who)]
    if {$n == -1} return                        ;# Not found, shouldn't happen
    incr n
    if {$n >= [llength $B(lvls)]} {incr n -1}   ;# Done them all
    set G(who) [lindex $B(lvls) $n]             ;# Let trace fire
}
proc LoadLevel {{lvl {}}} {
    global G L

    if {$lvl == {}} {set lvl $G(lvl)}
    set G(state) "play"
    set G(lvl) $lvl
    set G(ccnt) [llength $L($lvl)]
    set G(banner) ""
    set G(moves) 0

    set id 0
    array unset G car,*
    foreach car $L($lvl) {
        incr id
        # set color [expr {$id == 1 ? "red" : $dir eq "v" ? "cyan" : "yellow"}]
        set color [expr {$id == 1 ? "red" : [Pastel]}]
        set G(car,$id) [concat $car $color]
    }
    DrawBoard
    set G(show,solution) 0
    Solve
}
proc DrawBoard {{redraw 0}} {
    global B G

    .c delete car id banner banner2
    if {$redraw} {
        .c delete all

        # Determine size of everything
        set dw [expr {([winfo width .c] - 4*$B(m)) / $B(w)}]
        set dh [expr {([winfo height .c] - 4*$B(m)) / $B(h)}]
        set B(cell) [expr {$dw < $dh ? $dw : $dh}]

        # Outer wall coordinates
        foreach {t l . .} [GetCellXY 0 0] break
        foreach {r b . .} [GetCellXY $B(w) $B(h)] break
        foreach {x0 . x1 .} [GetCellXY $B(exit,row) $B(exit,col)] break

        incr t -$B(wall) ; incr l -$B(wall)
        incr r  $B(wall)  ; incr b  $B(wall)

        set xy [list $x0 $t $l $t $l $b $r $b $r $t $x1 $t]
        .c create line $xy -width $B(wall) -tag wall -joinstyle miter
        .c create line $x0 $t $x1 $t -width $B(wall) -tag door -fill red -capstyle butt
        set x [expr {($x0 + $x1) / 2}]
        .c create text $x $t -anchor c -tag exit -text EXIT \
            -font $::G(exit_font) -fill black

        for {set row 0} {$row < $B(h)} {incr row} {
            for {set col 0} {$col < $B(w)} {incr col} {
                set xy [GetCellXY $row $col]
                .c create rect $xy
            }
        }
    }
    # Now draw all the cars
    for {set id 1} {$id <= $G(ccnt)} {incr id} {
        DrawCar $id
    }
    .c itemconfig door -fill red
    .c itemconfig exit -fill black

    if {$G(banner) != ""} {
        .c create text 0 0 -tag banner -text $G(banner) \
            -font $::G(banner_font) -fill white
        set xy [.c bbox banner]
        .c create rect $xy -tag banner2 -fill black -outline gold -width $::G(banner_width)
        .c raise banner
        .c itemconfig door -fill {}
        .c itemconfig exit -fill {}
    }
}
proc GetCellXY {row col} {
    global B

    set row [expr {$row - $B(h2)}]
    set col [expr {$col - $B(w2)}]
    set x0 [expr {$col * $B(cell) + $B(m2)}]
    set y0 [expr {$row * $B(cell) + $B(m2)}]
    set x1 [expr {($col+1) * $B(cell) - $B(m2)}]
    set y1 [expr {($row+1) * $B(cell) - $B(m2)}]
    return [list $x0 $y0 $x1 $y1]
}
proc GetCellRowCol {x y} {
    set row [expr {int(floor($y / $::B(cell)) + $::B(h2))}]
    set col [expr {int(floor($x / $::B(cell)) + $::B(w2))}]
    return [list $row $col]
}

proc DrawCar {id} {
    global B G

    set tag car,$id
    lassign $::G(car,$id) dir len row col color
    set row2 [expr {$dir eq "v" ? ($row + $len - 1) : $row}]
    set col2 [expr {$dir eq "v" ? $col : ($col + $len - 1)}]

    foreach {X0 Y0 . .} [GetCellXY $row $col] break ;# Get coords
    foreach {. . X3 Y3} [GetCellXY $row2 $col2] break

    set x0 [expr {$X0 + 0}]
    set y0 [expr {$Y0 + 0}]
    set x3 [expr {$X3 - 0}]
    set y3 [expr {$Y3 - 0}]
    set w [expr {$x3 - $x0}]
    set h [expr {$y3 - $y0}]

    .c delete $tag
    roundRect .c $x0 $y0 $x3 $y3 5 -tag [list car $tag] -width 2 -fill $color -outline black

    if {$len == 2} {
        if {$dir eq "v"} {
            set xa [expr {$x0 + .15 * $w}]
            set xb [expr {$x3 - .15 * $w}]
            set ya [expr {$y0 + .35 * $h}]
            set yb [expr {$ya + 5}]
            set yc [expr {$y0 + .85 * $h}]
            .c create line $xa $y0 $x0 $ya -tag [list car $tag] -width 2
            .c create line $xb $y0 $x3 $ya -tag [list car $tag] -width 2
            .c create line $x0 $ya $x3 $ya -tag [list car $tag] -width 2
            roundRect .c $x0 $yb $x3 $yc 5 -tag [list car $tag] -outline black -fill {} -width 2
        } else {
            set ya [expr {$y0 + .15 * $h}]
            set yb [expr {$y3 - .15 * $h}]
            set xa [expr {$x0 + .35 * $w}]
            set xb [expr {$xa + 5}]
            set xc [expr {$x0 + .65 * $w}]
            .c create line $x0 $ya $xa $y0 -tag [list car $tag] -width 2
            .c create line $x0 $yb $xa $y3 -tag [list car $tag] -width 2
            .c create line $xa $y0 $xa $y3 -tag [list car $tag] -width 2
            roundRect .c $xb $y0 $xc $y3 5 -tag [list car $tag] -outline black -fill {} -width 2
        }
    } else {
        if {$dir eq "v"} {
            set xa [expr {$x0 + 3}]
            set xb [expr {$x3 - 3}]
            set ya [expr {$y0 + 3}]
            set yb [expr {$y0 + .70 * $B(cell)}]
            set yc [expr {$yb + 3}]
            set yd [expr {$y3 - 3}]
            roundRect .c $xa $ya $xb $yb 5 -tag [list car $tag] -outline black -fill {} -width 2
            roundRect .c $xa $yc $xb $yd 5 -tag [list car $tag] -outline black -fill {} -width 2

            set xc [expr {$xa + 6}]
            set xd [expr {($x0 + $x3) / 2}]
            set xe [expr {$xb - 6}]
            set ye [expr {$ya + 6}]
            set yf [expr {$yb - 6}]
            .c create line $xc $ye $xc $yf -tag [list car $tag] -width 5 -fill gray40
            .c create line $xd $ye $xd $yf -tag [list car $tag] -width 5 -fill gray40
            .c create line $xe $ye $xe $yf -tag [list car $tag] -width 5 -fill gray40
        } else {
            set xa [expr {$x0 + 3}]
            set xb [expr {$x0 + .70 * $B(cell)}]
            set xc [expr {$xb + 3}]
            set xd [expr {$x3 - 3}]
            set ya [expr {$y0 + 3}]
            set yb [expr {$y3 - 3}]
            roundRect .c $xa $ya $xb $yb 5 -tag [list car $tag] -outline black -fill {} -width 2
            roundRect .c $xc $ya $xd $yb 5 -tag [list car $tag] -outline black -fill {} -width 2

            set xe [expr {$xa + 6}]
            set xf [expr {$xb - 6}]
            set yc [expr {$ya + 6}]
            set yd [expr {($y0 + $y3) / 2}]
            set ye [expr {$yb - 6}]
            .c create line $xe $yc $xf $yc -tag [list car $tag] -width 5 -fill gray40
            .c create line $xe $yd $xf $yd -tag [list car $tag] -width 5 -fill gray40
            .c create line $xe $ye $xf $ye -tag [list car $tag] -width 5 -fill gray40
        }
    }
    .c bind $tag <Button-1> [list BDown $id %x %y]
    .c bind $tag <B1-Motion> [list BMove $id %x %y]
    .c bind $tag <ButtonRelease-1> [list BUp $id %x %y]
}
proc AddCarLabels {onoff} {
    global G
    .c delete id
    if { $onoff} {
        for {set id 1} {$id <= $G(ccnt)} {incr id} {
            lassign [.c bbox car,$id] x0 y0 x1 y1
            set x [expr {($x0 + $x1) / 2}]
            set y [expr {($y0 + $y1) / 2}]
            if {[lindex $G(car,$id) 0] eq "v"} { incr y 5 } else { incr x 3 }
            .c create text $x $y -text $id -tag [list car,$id id] -font $G(id_font)
        }
    }
}
##+##########################################################################
#
# Pastel -- returns a "pastel" color. Code is from X Windows tool xcolorize
# Pick "random" color in a subspace of the HSV color model and convert to RGB.
#
proc Pastel {} {
    set rand [expr {rand() * 262144}]
    set h [fmod $rand 360]
    set rand [expr {$rand / 359.3}]
    set s [expr {([fmod $rand 9] + 12) / 100.0}]
    set v 1

    # Convert to rgb space
    if {$h == 360} { set h 0 }
    set h [expr {$h/60}]
    set i [expr {int(floor($h))}]
    set f [expr {$h - $i}]
    set p1 [expr {$v*(1-$s)}]
    set p2 [expr {$v*(1-($s*$f))}]
    set p3 [expr {$v*(1-($s*(1-$f)))}]
    switch -- $i {
        0 { set r $v  ; set g $p3 ; set b $p1 }
        1 { set r $p2 ; set g $v  ; set b $p1 }
        2 { set r $p1 ; set g $v  ; set b $p3 }
        3 { set r $p1 ; set g $p2 ; set b $v  }
        4 { set r $p3 ; set g $p1 ; set b $v  }
        5 { set r $v  ; set g $p1 ; set b $p2 }
    }
    foreach a {r g b} { set $a [expr {int ([set $a] * 255)}] }
    return [format "\#%02x%02x%02x" $r $g $b]
}
proc fmod {num mod} {                           ;# Floating point modulus
    foreach {int frac} [split $num "."] break
    set frac "0.$frac"
    return [expr {($int % $mod) + $frac}]
}
proc roundRect { w x0 y0 x3 y3 radius args } {

    set d [expr { 2 * $radius }]

    # Make sure that the radius of the curve is less than 3/8
    # size of the box!

    set maxr 0.75

    if { $d > $maxr * ( $x3 - $x0 ) } {
        set d [expr { $maxr * ( $x3 - $x0 ) }]
    }
    if { $d > $maxr * ( $y3 - $y0 ) } {
        set d [expr { $maxr * ( $y3 - $y0 ) }]
    }

    set x1 [expr { $x0 + $d }]
    set x2 [expr { $x3 - $d }]
    set y1 [expr { $y0 + $d }]
    set y2 [expr { $y3 - $d }]

    set cmd [list $w create polygon]
    lappend cmd $x0 $y0
    lappend cmd $x1 $y0
    lappend cmd $x2 $y0
    lappend cmd $x3 $y0
    lappend cmd $x3 $y1
    lappend cmd $x3 $y2
    lappend cmd $x3 $y3
    lappend cmd $x2 $y3
    lappend cmd $x1 $y3
    lappend cmd $x0 $y3
    lappend cmd $x0 $y2
    lappend cmd $x0 $y1
    lappend cmd -smooth 1
    return [eval $cmd $args]
}
proc BDown {id x y} {
    global CAR G

    if {$G(state) ne "play"} return
    unset -nocomplain CAR
    set CAR(id) $id
    set CAR(mouse,x) $x
    set CAR(mouse,y) $y
    set CAR(before) $G(car,$id)

    lassign $G(car,$id) CAR(dir) CAR(len) CAR(row) CAR(col) .
    if {$CAR(dir) eq "v"} {
        for {set row [expr {$CAR(row)-1}]} {1} {incr row -1} {
            if {[WhoIsIn $row $CAR(col)] != 0} break
        }
        set CAR(row,min) [expr {$row + 1}]
        for {set row [expr {$CAR(row)+$CAR(len)}]} {1} {incr row} {
            if {[WhoIsIn $row $CAR(col)] != 0} break
        }
        set CAR(row,max) [expr {$row - 1}]

        set CAR(col,min) $CAR(col)
        set CAR(col,max) $CAR(col)
    } else {
        set CAR(row,min) $CAR(row)
        set CAR(row,max) $CAR(row)
        for {set col [expr {$CAR(col)-1}]} {1} {incr col -1} {
            if {[WhoIsIn $CAR(row) $col] != 0} break
        }
        set CAR(col,min) [expr {$col + 1}]
        for {set col [expr {$CAR(col)+$CAR(len)}]} {1} {incr col} {
            if {[WhoIsIn $CAR(row) $col] != 0} break
        }
        set CAR(col,max) [expr {$col - 1}]
    }

    foreach {x0 y0 . .} [GetCellXY $CAR(row,min) $CAR(col,min)] break
    foreach {. . x1 y1} [GetCellXY $CAR(row,max) $CAR(col,max)] break
    set CAR(xy) [list $x0 $y0 $x1 $y1]
    .c itemconfig car,$id -width 3
    .c itemconfig id -width 0
}
proc BMove {id x y} {
    global CAR

    if {$::G(state) ne "play"} return
    lassign [.c bbox car,$id] cx0 cy0 cx1 cy1    ;# Where we are now
    lassign $CAR(xy) x0 y0 x1 y1                 ;# Limit on motion

    set dx [expr {$x - $CAR(mouse,x)}]
    set dy [expr {$y - $CAR(mouse,y)}]
    set CAR(mouse,x) $x
    set CAR(mouse,y) $y

    set padding 3 ;# Bounding box is a bit too large
    if {$CAR(dir) eq "v"} {
        set dx 0
        if {$cy0 + $dy < $y0 - $padding || $cy1 + $dy > $y1 + $padding} return
    } else {
        if {$cx0 + $dx < $x0 - $padding || $cx1 + $dx > $x1 + $padding} return
        set dy 0
    }
    .c move car,$id $dx $dy
}
proc BUp {id x y} {
    global CAR G B

    if {$::G(state) ne "play"} return
    .c itemconfig car,$id -width 1
    .c itemconfig id -width 0
    lassign [.c coords car,$id] cx0 cy0 . .
    set cx0 [expr {$cx0 + $::B(cell) / 2}]
    set cy0 [expr {$cy0 + $::B(cell) / 2}]

    lassign [GetCellRowCol $cx0 $cy0] row col
    if {$row != [lindex $G(car,$id) 2] || $col != [lindex $G(car,$id) 3]} {
        incr G(moves)
    }
    lset G(car,$id) 2 $row
    lset G(car,$id) 3 $col
    DrawCar $id

    Solve
    if {[IsSolved]} Win
}
proc IsSolved {} {
    lassign $::G(car,1) dir len row col
    return [expr {$row == $::B(exit,row) && $col == $::B(exit,col)}]
}
proc WhoIsIn {row col} {
    if {$row < 0 || $col < 0 || $row >= $::B(w) || $col >= $::B(h)} {return 999}

    for {set i 1} {$i <= $::G(ccnt)} {incr i} { ;# Loop through all cars
        foreach {dir len r c} $::G(car,$i) break;# Get where the car is
        if {$dir eq "v"} {
            if {$col != $c} continue
            if {$row >= $r && $row < $r + $len} { return $i }
        } else {
            if {$row != $r} continue
            if {$col >= $c && $col < $c + $len} { return $i }
        }
    }
    return 0
}
proc Help {} {
    set msg "Rush Hour\nby Keith Vetter, September 2004\n\n"

    append msg "Rush Hour is a sliding block puzzle created by\n"
    append msg "Nob Yoshigahara, and is known by numerous other names\n"
    append msg "such as \"Car Jam\" and \"Traffic Jam\".\n\n"

    append msg "The object of the game is to move the red block out of\n"
    append msg "the grid but to do so you must move the other blocks out\n"
    append msg "the way.\n\n"

    if {$::tcl_platform(platform) eq "unix"} {
        set msg [string map {\n\n \n\n \n " "} $msg]
    }
    tk_messageBox -message $msg -title "Rush Hour Help"
}
proc Win {} {
    set ::G(state) "won"
    set ::G(banner) " You Won! "
    DrawBoard
    Solve

    .c bind banner <Button-1> NextLevel
    .c bind banner2 <Button-1> NextLevel
}
proc QInit {} {
    unset -nocomplain ::Q
    set ::Q(head) 0
    set ::Q(tail) 0
}
proc QPush {brd pred} {
    incr ::Q(head)
    set ::Q($::Q(head)) [list $brd $pred]
    set ::Q(visited,$brd) $pred
    return $::Q(head)
}
proc QPop {} {
    incr ::Q(tail)
    return $::Q(tail)
}
proc QEmpty {} {
    return [expr {$::Q(tail) == $::Q(head)}]
}
proc QVisited {brd} {
    return [info exists ::Q(visited,$brd)]
}

proc Solve {} {
    global G

    if {! $G(show,solution)} {
        pack forget .solution
        AddCarLabels 0
        return
    }

    pack .solution -side right -fill both -expand 1
    if {$G(state) eq "won"} {
        AddCarLabels 0
        set G(solution) [list "Solved"]
        return
    }
    AddCarLabels 1
    set sln [::Solver::Solve]
    set G(solution) {}
    for {set i 1} {$i < [llength $sln]} {incr i} {
        set prev [lindex $sln $i-1]
        set this [lindex $sln $i]
        set delta [::Solver::MoveInEnglish $prev $this]
        lappend G(solution) [format "%2d: %s" $i $delta]
    }
}
namespace eval ::Solver {
    variable BD
}

proc ::Solver::Solve {} {
    set sln [::Solver::AlreadySolved]
    if {$sln ne {}} { return $sln }
    set isSolved [::Solver::BFS]
    if {! $isSolved} { puts "no solution" }
    set sln [::Solver::GetSolution]
    return $sln
}

proc ::Solver::BFS {} {
    QInit
    QPush [::Solver::Init] -
    while {! [QEmpty]} {
        set qitem [QPop]
        lassign $::Q($qitem) brd .

        set allMoves [::Solver::GetMoves $brd]
        foreach move $allMoves {
            set newBrd [lindex $move 2]
            if {[QVisited $newBrd]} continue
            QPush $newBrd $qitem
            if {[::Solver::IsSolved $newBrd]} {
                return 1
            }
        }
    }
    return 0
}
proc ::Solver::GetSolution {{qid {}}} {
    if {$qid eq {}} { set qid $::Q(head) }
    set result {}
    while {$qid ne "-"} {
        lassign $::Q($qid) brd pred
        lappend result $brd
        set qid $pred
    }
    set result [lreverse $result]
    return $result
}
proc ::Solver::AlreadySolved {} {
    if {! [info exists ::Q(head)]} { return {}}
    set thisBoard [::Solver::Init]
    set qid $::Q(head)
    set result {}
    while {$qid ne "-"} {
        lassign $::Q($qid) brd pred
        lappend result $brd
        if {$brd eq $thisBoard} {
            return [lreverse $result]
        }
        set qid $pred
    }
    return {}
}

proc ::Solver::MoveInEnglish {prev this} {
    for {set id 1} {$id <= [llength $this]} {incr id} {
        if {[lindex $prev $id-1] eq [lindex $this $id-1]} continue
        lassign [lindex $prev $id-1] . . row0 col0
        lassign [lindex $this $id-1] . . row1 col1
        if {$row1 < $row0} {
            return "move $id up [expr {$row0 - $row1}]"
        } elseif {$row1 > $row0} {
            return "move $id down [expr {$row1 - $row0}]"
        } elseif {$col1 < $col0} {
            return "move $id left [expr {$col0 - $col1}]"
        } elseif {$col1 > $col0} {
            return "move $id right [expr {$col1 - $col0}]"
        } else { error "bad move" }
    }
    error "no change"
}
proc ::Solver::IsSolved {brd} {
    lassign [lindex $brd 0] dir len row col
    return [expr {$row == $::B(exit,row) && $col == $::B(exit,col)}]
}
proc ::Solver::GetMoves {brd} {
    variable BD
    ::Solver::ExplodeBoard $brd

    set moves {}
    for {set id 1} {$id <= $BD(cars)} {incr id} {
        lassign [lindex $brd $id-1] dir len row0 col0
        if {$dir eq "v"} {
            for {set row [expr {$row0 - 1}]} {1} {incr row -1} {
                if {$row < 0 || $BD(b,$row,$col0) != 0} break
                lappend moves [list $id up [lreplace $brd $id-1 $id-1 [list $dir $len $row $col0]]]
            }
            for {set row [expr {$row0 + 1}]} {1} {incr row} {
                set end [expr {$row + $len - 1}]
                if {$end >= $BD(height) || $BD(b,$end,$col0) != 0} break
                lappend moves [list $id down [lreplace $brd $id-1 $id-1 [list $dir $len $row $col0]]]
            }
        } else {
            for {set col [expr {$col0 - 1}]} {1} {incr col -1} {
                if {$col < 0 || $BD(b,$row0,$col) != 0} break
                lappend moves [list $id left [lreplace $brd $id-1 $id-1 [list $dir $len $row0 $col]]]
            }
            for {set col [expr {$col0 + 1}]} {1} {incr col} {
                set end [expr {$col + $len - 1}]
                if {$end >= $BD(width) || $BD(b,$row0,$end) != 0} break
                lappend moves [list $id right [lreplace $brd $id-1 $id-1 [list $dir $len $row0 $col]]]
            }
        }
    }
    return $moves
}


proc ::Solver::ExplodeBoard {brd} {
    variable BD

    array unset BD b,*

    for {set row 0} {$row < $BD(width)} {incr row} {
        for {set col 0} {$col < $BD(height)} {incr col} {
            set BD(b,$row,$col) 0
        }
    }
    for {set id 1} {$id <= $BD(cars)} {incr id} {
        lassign [lindex $brd $id-1] dir len row col
        for {set i 0} {$i < $len} {incr i} {
            set BD(b,$row,$col) $id
            if {$dir eq "v"} { incr row } else { incr col }
        }
    }
}
proc ::Solver::Init {} {
    variable BD
    global G B

    unset -nocomplain BD
    set BD(width) $B(w)
    set BD(height) $B(h)
    set BD(cars) [llength [array names G car,*]]

    set BD(brd) {}
    for {set id 1} {$id <= $BD(cars)} {incr id} {
        lappend BD(brd) [lrange $G(car,$id) 0 3]
    }
    return $BD(brd)
}
proc ::Solver::ShowBoard {brd} {
    variable BD

    ::Solver::ExplodeBoard $brd
    for {set row 0} {$row < $BD(width)} {incr row} {
        set line ""
        for {set col 0} {$col < $BD(height)} {incr col} {
            set who [expr {[info exists BD(b,$row,$col)] ? $BD(b,$row,$col) : 0}]
            append line [format "%2d " $who]
        }
        set line [string map {" 0 " " . " " 1 " " @ "} $line]
        puts $line
    }
    puts ""
}

Init
update
set G(who) [lindex $B(lvls) 0]

return

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References