[Keith Vetter] 2004-09-13 : Rush Hour is a block sliding puzzle originally by
Nob Yoshigahara [http://www.puzzles.com/products/rushhour.htm]. 
The board game uses various color cars and the goal
is to get the red car out of the traffic jam. In this version, the goal
is to get the red block out of the grid.

[KPV] 2016-04-19 : I finally went and added a ''Solve'' button. It does a BFS to find the
optimal solution. I also fancied up the graphics a bit.

[WikiDbImage rushhour.gif]

This version has only 12 levels to play with. There are versions out on
the web with thousands of levels available.

[AK]:
   1. This needs a reset button, to get to the starting position if you have jammed yourself into a corner.
   1. 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.
   1. 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 ?

[KPV] Okay, I've added a reset button (although the functionality was already there if you
set the level back to itself) and I've emailed off to the main Rush Hour page asking for a link.

As to the 15,000 levels, I started to look into this but decided to go to bed instead. Here's
what I found out: there's a Gnome version of this game called gtraffic [http://linux.tucows.com/preview/58021.html] for which someone wrote a level generator called gtlevel [http://alpha.luc.ac.be/Research/Algebra/Members/Gtlevel/gtlevel.html]. There's also
an existing tcl version of this game [http://alpha.luc.ac.be/Research/Algebra/Members/Ttraffic/ttraffic.html] that comes with 15,000 levels built by gtlevel but in a proprietary binary format. I was trying to decipher this convoluted format when I decided to give up and go to bed.

If anyone wants to help decipher them, I'll be willing to set up some kind of automatic
download or whatever.

[AK]: Thanks for the Reset button, and for submitting the link. The other way of getting the reset, well, I never thought of that. I also know a version of Traffic for my Palm pilot, however the levels seem to be hardwired into the app, maybe a resource. As for the TTraffic binary file ... The application code is open, so it should be possible to determine the format by looking at this code. To avoid the GPL trap we would however have to document the format first, and then write our own reader, completely independent. ... Ok, I thought about using gtlevel directly, but it seems to be by the same person, and uses the same data format. :( Which means that this is also the data format of gtraffic. On the other hand, you can tell to generate only one level. Together with looking what [[gt]]traffic makes of it this will also help in deciphering the format ... Ok, enough with the random musings and ramblings. I might have a go and looking at the ttraffic code, or not. Thanks Keith, for this nice little gem/game.

[AK]: Found a bit more, after reading the gtlevel README. It seems that it is able to generate ASCII levels as well. And there is a wee bit documentation for the gtraffic level format in the gtlevel distribution as well.

----
See also [Rush Hour (PocketPC)]
----
[HZe] 2006-01-15: I created another port to [PocketPC], but this time single-source with this version below. Depending on the maximum screen size I modify some settings and configurations, so that the game can be played on a small display. Looks like this:

[http://holgerzeinert.gmxhome.de/share/rushhour_pocketpc.gif]

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

======
----

[uniquename] 2013aug01

Here is an image of the 'desktop-sized' version --- with the control buttons --- and 'locally stored' on this wiki, as insurance, in case
the pocket-PC-sized image-link above, at 'external site' gmxhome.de, goes dead.


[vetter_RushHour_screenshot_406x530.jpg]

<<categories>> Games | Application | Tcl/Tk Games