[Richard Suchenwirth] 2004-09-16 - Some tweaks to [Rush Hour] to make it play well on my [iPaq]:

[http://mini.net/files/rushhour.jpg]

----
    set msg "Rush Hour
 by Keith Vetter, September 2004
 iPaq port: R. Suchenwirth

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

 The object of the game is to move the red block out of the grid; but to do so you must move the other\
 blocks out of the way."
 # http://www.puzzles.com/products/rushhour.htm
 # gtlevel: http://alpha.luc.ac.be/Research/Algebra/Members/Gtlevel/gtlevel.html
 #

 package require Tk

 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) ""
    array set ::B {w 6 h 6 exit,row 0 exit,col 2 m 5 m2 5 wall 7}
    set ::B(w2) [expr {$::B(w) / 2}]
    set ::B(h2) [expr {$::B(h) / 2}]

    wm title . "Rush Hour"
    canvas .c -width 240 -height 240 -highlightthickness 0

    frame .bot -bd 2
    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
    }

    eval tk_optionMenu .lvl ::G(who) $::B(lvls)
    trace variable ::G(who) w ChangeLevel
    button .reset -text "Reset" -command LoadLevel
    button .next -text "Level+" -command NextLevel
    button .help -text "Help" -command Help

    pack .bot -side bottom -fill both
    pack .c -side top -fill both -expand 1
    pack .lvl .reset .next -in .bot -side left -expand 1
    pack .help -in .bot -side right
    bind .c <Configure> {ReCenter %W %h %w}
 }
 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) 0                              ;# Playing
    set G(lvl) $lvl
    set G(ccnt) [llength $L($lvl)]
    set G(banner) ""

    set id 0
    foreach car $L($lvl) {
        incr id
        set G(car,$id) $car
    }
    DrawBoard
 }
 proc DrawBoard {{redraw 0}} {
    global S B G

    .c delete car 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 wall -fill red \
            -capstyle butt
        set x [expr {($x0 + $x1) / 2}]
        .c create text $x $t -anchor c -tag exit -text EXIT \
            -font {Helvetica 7 bold} -fill yellow

        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 -outline white
            }
        }
    }
    # Now draw all the cars
    for {set id 1} {$id <= $G(ccnt)} {incr id} {
        DrawCar $id
    }
    if {$G(banner) != ""} {
        .c create text 0 0 -tag banner -text $G(banner) \
            -font {Times 24 bold} -fill white
        set xy [.c bbox banner]
        .c create rect $xy -tag banner2 -fill black -outline gold -width 4
        .c raise banner
    }
 }
 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} {
    .c delete car,$id
    foreach {dir len row col} $::G(car,$id) break
    if {$dir eq "v"} {                          ;# Get ending cell
        set row2 [expr {$row + $len - 1}]
        set col2 $col
    } else {
        set row2 $row
        set col2 [expr {$col + $len - 1}]
    }
    foreach {x0 y0 . .} [GetCellXY $row $col] break ;# Get coords
    foreach {. . x1 y1} [GetCellXY $row2 $col2] break

    set color [expr {$id == 1 ? "red" : $dir eq "v" ? "blue" : "green"}]
    .c create rect $x0 $y0 $x1 $y1 -tag [list car car,$id] -width 1 -fill $color
    .c bind car,$id <Button-1> [list BDown $id %x %y]
    .c bind car,$id <B1-Motion> [list BMove $id %x %y]
    .c bind car,$id <ButtonRelease-1> [list BUp $id %x %y]
 }
 proc BDown {id x y} {
    global CAR G

    if {$G(state) != 0} return
    unset -nocomplain CAR
    set CAR(id) $id
    set CAR(x) $x
    set CAR(y) $y

    foreach {CAR(dir) CAR(len) CAR(row) CAR(col)} $G(car,$id) break
    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 -outline white
 }
 proc BMove {id x y} {
    global CAR

    if {$::G(state) != 0} return
    foreach {cx0 cy0 cx1 cy1} [.c coords car,$id] break ;# Where we are now
    foreach {x0 y0 x1 y1} $CAR(xy) break        ;# Limit on motion

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

    if {$CAR(dir) eq "v"} {
        set dx 0
        if {$cy0 + $dy < $y0 || $cy1 + $dy > $y1} return
    } else {
        if {$cx0 + $dx < $x0 || $cx1 + $dx > $x1} return
        set dy 0
    }
    .c move car,$id $dx $dy
 }
 proc BUp {id x y} {
    global CAR G B

    if {$::G(state) != 0} return
    .c itemconfig car,$id -outline black
    foreach {cx0 cy0 . .} [.c coords car,$id] break ;# Where we are now
    set cx0 [expr {$cx0 + $::B(cell) / 2}]
    set cy0 [expr {$cy0 + $::B(cell) / 2}]

    foreach {row col} [GetCellRowCol $cx0 $cy0] break
    #lset G(car,$id) 2 $row
    set G(car,$id) [lreplace $G(car,$id) 2 2 $row]
    #lset G(car,$id) 3 $col
    set G(car,$id) [lreplace $G(car,$id) 3 3 $col]

    DrawCar $id

    if {$id == 1 && $row == $B(exit,row) && $col == $B(exit,col)} {
        Win
    }

 }
 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 {} {
    tk_messageBox -message $::msg -title "Rush Hour Help"
 }
 proc Win {} {
    set ::G(state) 1
    set ::G(banner) " You Won! "
    DrawBoard

    set bg [.c cget -bg]
    for {set i 0} {$i < 4} {incr i} {
        foreach color [list white $bg] {
            .c config -bg $color
            update
            after 100
        }
    }
    .c bind banner <Button-1> NextLevel
    .c bind banner2 <Button-1> NextLevel
 }
 Init
 update
 LoadLevel 1
 wm geometry . 240x268+0+0
 bind . <Up> {exec wish $argv0 &; exit}


----
[Category Game]