[Keith Vetter] 2005-11-18 : Somehow my family acquired the 
board game ''Junior Labyrinth''. We have a lot of fun playing
it despite not having any instructions and lacking a few pieces.

I thought I'd try writing a tcl version of the
game. This was one of those fun projects that started off
small and incrementally grew bigger as I added
''just one more feature''. Initially it was just the sliding
tiles (see also [Shifting Maze]), then stippling for the
brick look, then moving players, then.... The next thing I 
knew I had a complete game.

Except that I still don't know how the game is officially played, 
so I used the rules that we use in our house. The objective
is to be the first player to collect 15 gems. The players
rotate taking turns. A players turn consists of two parts, 
first sliding a tile to change the maze and then moving the 
piece to capture the gem. A player's turn is over 
when he either captures the gem or he presses the DONE button.


----
 ##+##########################################################################
 #
 # Labyrinth.tcl -- Plays Junior Labyrinth
 # by Keith Vetter, Nov 2005
 #
 
 package require Tk
 
 set S(title) "Junior Labyrinth"
 set S(version) "1.0"
 set S(sz) 100                                   ;# Tile size
 set S(wall) [expr {$S(sz) / 4.0}]               ;# Wall thickness
 set S(pad) 2                                    ;# Space between tiles
 set S(m) $S(sz)                                 ;# Margin
 set S(n) 5                                      ;# How many rows and columns
 set S(nn) [expr {$S(n)-1}]
 set S(bsize) [expr {$S(n)*$S(sz) + $S(nn)*$S(pad)}]
 set S(blink,on) 2000
 set S(blink,off) 500
 set S(delay) 10                                 ;# Time between animation steps
 set S(step) 2                                   ;# Animation step size
 set S(goal) 15                                  ;# Winning total
 
 set S(players) 2                                ;# How many players
 set S(state) pick
 set S(key) ""
 set S(turn) [expr {$S(players)-1}]
 
 array set COLORS {
    board yellow . saddlebrown bg green4 arrow yellow txt deepskyblue gem skyblue
    brick red mortar black score,bg black score,fg white
    player,0 magenta player,1 green player,2 cyan player,3 red
 }
 
 array set TILES {corner 8 tee 7 line 2}
 set FIXED {0 0 rb 0 2 lbr 0 4 lb 2 0 trb 2 2 lr 2 4 tlb 4 0 tr 4 2 trl 4 4 tl}
 array set RAND {c {tr tl rb lb} t {trl trb rlb tlb} l {lr tb}}
 array set DIR {Up {-1 0} Down {1 0} Left {0 -1} Right {0 1}}
 array set DIR2 {1,0 Down -1,0 Up 0,1 Right 0,-1 Left}
 array set SCORE {0 0 1 0 2 0 3 0}
 set PI [expr {acos(-1)}]
 
 proc DoDisplay {} {
    global S COLORS
    option add *Canvas.highlightThickness 0
 
    wm title . $S(title)
    . config -bg $COLORS(.)
    DoMenus
 
    GetBoxesBMP
    frame .s -bg $COLORS(score,bg) -bd 2 -relief ridge -padx 5
 
    set w [expr {$S(m) + $S(bsize) + $S(m)}]
    set h [expr {$S(m) + $S(bsize) + $S(m)}]
 
    canvas .title -width $w -bd 0 -bg $COLORS(bg)
    ShadedText .title [expr {$w/2}] 10 $COLORS(txt) black -text $S(title) \
        -font {Times 42 bold} -anchor n -tag title
    .title config -height [lindex [.title bbox title] 3]
 
    canvas .c -width $w -height $h -bd 0 -bg $COLORS(bg)
    .c create rect -10 -10 10000 10000 -fill $COLORS(bg) -tag bg
    image create photo ::img::rot -data $::rotImage
    button .rot -image ::img::rot -command RotateTile
    .c create window [LocateTile rotate rotate 1] -tag rotate -window .rot
    button .done -text "Done" -font {Helvetica 12 bold} \
        -command {NewState done} -height 2
    .c create window [LocateTile extra extra 1] -tag done -window .done
 
    MakeScoreArea
    label .msg -textvariable S(msg) -font {Times 32 bold} -bg $COLORS(bg)
    foreach {x0 y0} [LocateTile 0 0] break
    foreach {. . x1 y1} [LocateTile $S(nn) $S(nn)] break
    .c create rect $x0 $y0 $x1 $y1 -tag board -fill $COLORS(board) \
        -outline $COLORS(board)
 
    foreach {r c d} {-1 1 s -1 3 s 5 1 n 5 3 n 1 -1 e 3 -1 e 1 5 w 3 5 w} {
        MakeArrow $r $c $d
    }
    NewBoard
 
    pack .s -side right -fill y
    pack .title -side top -fill x
    pack .c -side top -fill both -expand 1 -pady .2i -padx .2i \
        -ipadx 5 -ipady 5
    pack .msg -side bottom -fill x
    foreach key {Up Down Left Right} {
        bind .c <KeyPress-$key> [list KeyPress %K press]
        bind .c <KeyRelease-$key> [list KeyPress %K release]
    }
    bind all <Key-F2> {console show}
    focus .c
    wm geom . +5+5
 }
 proc DoMenus {} {
    option add *Menu.tearOff 0
    menu .menu
    . config -menu .menu
 
    menu .menu.game
    .menu add cascade -label "Game" -menu .menu.game -underline 0
    .menu.game add command -label "New Game" -command NewGame
 
    set m .menu.game.players
    menu $m
    .menu.game add cascade -label "Players" -menu $m -underline 0
    foreach n {2 3 4} {
        $m add radio -label "$n Players" \
            -variable S(players) \
            -value $n \
            -underline 0 \
            -command NewGame
    }
    .menu.game add separator
    .menu.game add command -label "Exit" -command exit
 
    menu .menu.help
    .menu add cascade -label "Help" -menu .menu.help -underline 0
    .menu.help add command -label "Help" -command Help
    .menu.help add command -label "About" -command About
 }
 proc MakePlayers {} {
    foreach {who row col} {0 0 0 1 0 4 2 4 0 3 4 4} {
        .c delete player,$who
        if {$who >= $::S(players)} continue
        DrawPlayer $who $row $col
        set ::PLAYERS($who) [list $row $col]
 
        .c bind player,$who <ButtonPress-1> [list BDown $who]
        .c bind player,$who <B1-Motion> [list BMotion $who %x %y]
        .c bind player,$who <ButtonRelease-1> [list BUp $who]
    }
 }
 proc MakeScoreArea {} {
    global S COLORS SCORE
 
    eval destroy [winfo child .s]
    set csize 75
 
    label .s.title -text Score -font {Times 42 bold underline} \
        -bg $COLORS(score,bg) -fg $COLORS(score,fg)
    grid .s.title - -sticky ew -row 1
    for {set who 0} {$who < $S(players)} {incr who} {
        canvas .s.$who -width $csize -height $csize \
            -bg $COLORS(score,bg) -bd 5 -relief flat
        DrawPlayerAt 10 10 $csize $csize $COLORS(player,$who) tag .s.$who
        label .s.l$who -textvariable SCORE($who) -font {Times 36 bold} \
            -bg $COLORS(score,bg) -fg $COLORS(score,fg) -width 3
        grid .s.$who .s.l$who -sticky news -pady 20
    }
    grid rowconfigure .s 60 -weight 1
 }
 proc ShadedText {w x y fg bg args} {
    set cbg [ $w cget -bg ]
    eval [list $w create text $x $y -fill $bg] $args
    eval [list $w create text [incr x -2] [incr y -2] -fill $cbg] $args
    eval [list $w create text [incr x -1] [incr y -1] -fill  $fg] $args
 }
 proc FillBoard {} {
    global S FIXED BOARD TILES RAND
 
    .c delete win
    unset -nocomplain BOARD
    set id -1
    foreach {row col doors} $FIXED {
        MakeTile "fixed,[incr id]" [LocateTile $row $col] $doors
        set BOARD(doors,$row,$col) $doors
    }
    set S(deck) [Shuffle [concat [string repeat "c " $TILES(corner)] \
                           [string repeat "t " $TILES(tee)] \
                           [string repeat "l " $TILES(line)]]]
    set idx -1
    for {set row 0} {$row < $S(n)} {incr row} {
        for {set col 0} {$col < $S(n)} {incr col} {
            if {[info exists BOARD(doors,$row,$col)]} continue
 
            set type [lindex $S(deck) [incr idx]]
            set doors [lindex $RAND($type) \
                           [expr {int(rand() * [llength $RAND($type)])}]]
            MakeTile "tile,$idx" [LocateTile $row $col] $doors
            set BOARD(doors,$row,$col) $doors
            set BOARD(tag,$row,$col) "tile,$idx"
        }
    }
 
    set type [lindex $S(deck) [incr idx]]
    set doors [lindex $RAND($type) \
                   [expr {int(rand() * [llength $RAND($type)])}]]
    MakeTile "tile,$idx" [LocateTile extra extra] $doors
    set BOARD(doors,extra) $doors
    set BOARD(tag,extra) "tile,$idx"
 }
 proc LocateTile {row col {mid 0}} {
    global S
 
    if {$row eq "extra"} {
        return [LocateTile $S(n) $S(n) $mid]
    }
    if {$row eq "rotate"} {
        return [LocateTile $S(n) $S(nn) $mid]
    }
 
    set x0 [expr {$S(m) + $col*($S(sz)+$S(pad))}]
    set y0 [expr {$S(m) + $row*($S(sz)+$S(pad))}]
    if {$mid} {
        return [list [expr {$x0 + $S(sz)/2}] [expr {$y0 + $S(sz)/2}]]
    }
    set x1 [expr {$x0 + $S(sz)}]
    set y1 [expr {$y0 + $S(sz)}]
    return [list $x0 $y0 $x1 $y1]
 }
 proc Canvas2Tile {x y} {
    global S
 
    set sz [expr {$S(sz) + $S(pad)}]
    set row [expr {int(($y - $S(m) + $S(pad)/2 - 1) / $sz)}]
    set col [expr {int(($x - $S(m) + $S(pad)/2 - 1) / $sz)}]
    return [list $row $col]
 }
 proc MakeArrow {row col dir} {
    array set D {
        s {2 1 2 4}
        n {2 3 2 0}
        e {1 2 4 2}
        w {3 2 0 2}
    }
 
    foreach {x(0) y(0) x(4) y(4)} [LocateTile $row $col] break
 
    set x(1) [expr {$x(0) + ($x(4)-$x(0))/4}]
    set x(2) [expr {($x(0) + $x(4))/2}]
    set x(3) [expr {$x(4) - ($x(4)-$x(0))/4}]
    set y(1) [expr {$y(0) + ($y(4)-$y(0))/4}]
    set y(2) [expr {($y(0) + $y(4))/2}]
    set y(3) [expr {$y(4) - ($y(4)-$y(0))/4}]
 
    set xy {}
    foreach {dx dy} $D($dir) {
        lappend xy $x($dx) $y($dy)
    }
    set id [.c create line $xy -tag arrow -width 10 -capstyle round \
                -fill $::COLORS(arrow) -arrow last -arrowshape {16 24 11}]
    .c bind $id <1> [list Shift $row $col]
 }
 proc MakeTile {tag rect doors} {
    global S COLORS
    array set PARTS {
        lr {n s}
        bt {e w}
        br {Lnw se}
        bl {Lne sw}
        rt {Lsw ne}
        lt {Lse nw}
        lrt {s nw ne}
        brt {w ne se}
        blr {n se sw}
        blt {e nw sw}
    }
 
    .c delete $tag
    .c create rect $rect -width 0 -fill $COLORS(board) -tag $tag
    set doors [join [lsort [split $doors ""]] ""]
    foreach part $PARTS($doors) {
        set xy [GetSubCoords $rect $part]
        .c create poly $xy -tag $tag -fill $COLORS(brick) -outline $COLORS(mortar)
        .c create poly $xy -tag $tag -fill $COLORS(mortar) -stipple @$S(bmp)
    }
 }
 proc GetSubCoords {rect what} {
    array set XY {
        n {$x0 $y0 $x1 $y0 $x1 $yq1 $x0 $yq1}
        s {$x0 $yq2 $x1 $yq2 $x1 $y1 $x0 $y1}
        w {$x0 $y0 $xq1 $y0 $xq1 $y1 $x0 $y1}
        e {$xq2 $y0 $x1 $y0 $x1 $y1 $xq2 $y1}
        ne {$xq2 $y0 $x1 $y0 $x1 $yq1 $xq2 $yq1}
        nw {$x0 $y0 $xq1 $y0 $xq1 $yq1 $x0 $yq1}
        se {$xq2 $yq2 $x1 $yq2 $x1 $y1 $xq2 $y1}
        sw {$x0 $yq2 $xq1 $yq2 $xq1 $y1 $x0 $y1}
        Lsw {$x0 $y0 $xq1 $y0 $xq1 $yq2 $x1 $yq2 $x1 $y1 $x0 $y1}
        Lnw {$x0 $y0 $x1 $y0 $x1 $yq1 $xq1 $yq1 $xq1 $y1 $x0 $y1}
        Lne {$x0 $y0 $x1 $y0 $x1 $y1 $xq2 $y1 $xq2 $yq1 $x0 $yq1}
        Lse {$xq2 $y0 $x1 $y0 $x1 $y1 $x0 $y1 $x0 $yq2 $xq2 $yq2}
    }
 
    foreach {x0 y0 x1 y1} $rect break
    set xq1 [expr {$x0+$::S(wall)}]
    set xq2 [expr {$x1-$::S(wall)}]
    set yq1 [expr {$y0+$::S(wall)}]
    set yq2 [expr {$y1-$::S(wall)}]
 
    set xy [subst -nocommands -nobackslashes $XY($what)]
    return $xy
 }
 proc Shuffle { l } {
    set len [llength $l]
    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 $l $i]
        lset l $i [lindex $l $n]
        lset l $n $temp
    }
    return $l
 }
 proc NewBoard {} {
    FillBoard
    MakePlayers
    RandomGem
 }
 proc NewState {new} {
    global S COLORS BOARD SCORE
 
    if {$new eq "gem"} {
        BUp $S(turn)
        KillGem
        incr SCORE($S(turn))
        if {$SCORE($S(turn)) >= $S(goal)} {
            Winner $S(turn)
            set S(state) win
            .c itemconfig done -window {}
            return
        }
        RandomGem
        set new done
    }
 
    if {$new eq "done"} {
        .s.$S(turn) config -relief flat
        set S(turn) [expr {($S(turn)+1) % $S(players)}]
        .s.$S(turn) config -relief ridge
        #.s.cturn itemconfig player -fill $COLORS(player,$S(turn)) \
            -outline $COLORS(player,$S(turn))
        set S(msg) "Click Arrow to Slide Tiles"
        .c raise arrow bg
        .c raise $BOARD(tag,extra) bg
        .c raise player,$S(turn)
        .c raise gem
        .c itemconfig rotate -window .rot
        .c itemconfig done -window {}
        set S(state) pick
        BlinkArrows 0
    } else {
        set S(state) $new
        .c lower arrow bg
        .c lower $BOARD(tag,extra) bg
        .c itemconfig rotate -window {}
        if {$S(state) eq "move"} {
            set S(msg) "Move Player to Capture Gem"
            .c itemconfig done -window .done
        }
    }
 }
 proc Shift {row col} {
    if {$::S(state) ne "pick"} return
    NewState shift
    if {$row == -1} { ShiftCol $col 1 }
    if {$row == $::S(n)} { ShiftCol $col -1 }
 
    if {$col == -1} { ShiftRow $row 1 }
    if {$col == $::S(n)} { ShiftRow $row -1 }
    NewState move
 }
 proc ShiftRow {row dir} {
    if {$dir == 1} {
        MoveTileTo $::BOARD(tag,extra) $row -1
        set u {extra save 4 extra 3 4 2 3 1 2 0 1 save 0}
    } else {
        MoveTileTo $::BOARD(tag,extra) $row 5
        set u {0 save 1 0 2 1 3 2 4 3 extra 4 save extra}
    }
    set tags [GetRowColTags row $row]
    set players [PlayersOnRowCol row $row]
    foreach player $players { lappend tags "player,$player" }
    set gems [GemsOnRowCol row $row]
    foreach tag $gems { lappend tags $tag }
    update; after 500
    DoShift $tags $dir 0
    vwait ::S(vwait)
 
    foreach {from to} $u {
        set from [Index $row $from]
        set to [Index $row $to]
        UpdateBoard $from $to
    }
    MoveTileTo $::BOARD(tag,extra) extra extra
    UpdatePlayers $players $dir 0
    UpdateGem $gems $dir 0
 }
 proc ShiftCol {col dir} {
    if {$dir == 1} {
        MoveTileTo $::BOARD(tag,extra) -1 $col
        set u {extra save  4 extra 3 4 2 3 1 2 0 1 save 0}
    } else {
        MoveTileTo $::BOARD(tag,extra) $::S(n) $col
        set u {0 save 1 0 2 1 3 2 4 3 extra 4 save extra}
    }
    set tags [GetRowColTags col $col]
    set players [PlayersOnRowCol col $col]
    foreach player $players { lappend tags "player,$player" }
    set gems [GemsOnRowCol col $col]
    foreach tag $gems { lappend tags $tag }
    update ; after 500
    DoShift $tags 0 $dir
    vwait ::S(vwait)
 
    foreach {from to} $u {
        set from [Index $from $col]
        set to [Index $to $col]
        UpdateBoard $from $to
    }
    MoveTileTo $::BOARD(tag,extra) extra extra
    UpdatePlayers $players 0 $dir
    UpdateGem $gems 0 $dir
 }
 proc UpdateGem {who dx dy} {
    if {$who eq {}} return
    foreach {r c} [split $::GEM ","] break
    incr r $dy
    incr c $dx
    set off 0
    if {$r < 0} { set off 1 ; set r $::S(nn)}
    if {$r > $::S(nn)} { set off 1 ; set r 0}
    if {$c < 0} { set off 1 ; set c $::S(nn)}
    if {$c > $::S(nn)} { set off 1 ; set c 0}
    set ::GEM "$r,$c"
    if {$off} { DrawGem $r $c }
 }
 proc UpdatePlayers {who dx dy} {
    foreach player $who {
        foreach {r c} $::PLAYERS($player) break
        incr r $dy
        incr c $dx
        set off 0
        if {$r < 0} { set off 1 ; set r $::S(nn)}
        if {$r > $::S(nn)} { set off 1 ; set r 0}
        if {$c < 0} { set off 1 ; set c $::S(nn)}
        if {$c > $::S(nn)} { set off 1 ; set c 0}
        set ::PLAYERS($player) [list $r $c]
        if {$off} { DrawPlayer $player $r $c }
    }
 }
 proc PlayersOnRowCol {what which} {
    set cells [CellsOnRowCol $what $which]
    set result {}
    for {set player 0} {$player < $::S(players)} {incr player} {
        foreach {r c} $::PLAYERS($player) break
        set n [lsearch $cells "$r,$c"]
        if {$n != -1} { lappend result $player }
    }
    return $result
 }
 proc GemsOnRowCol {what which} {
    set cells [CellsOnRowCol $what $which]
    if {[lsearch $cells $::GEM] != -1} { return gem}
    return {}
 }
 proc CellsOnRowCol {what which} {
    set cells {}
    for {set idx 0} {$idx < $::S(n)} {incr idx} {
        if {$what eq "row"} {
            lappend cells $which,$idx
        } else {
            lappend cells $idx,$which
        }
    }
    return $cells
 }
 proc GetRowColTags {what who} {
    set tags $::BOARD(tag,extra)
    for {set idx 0} {$idx < $::S(n)} {incr idx} {
        if {$what eq "row"} {
            lappend tags $::BOARD(tag,$who,$idx)
        } else {
            lappend tags $::BOARD(tag,$idx,$who)
        }
    }
    return $tags
 }
 proc UpdateBoard {from to} {
    global BOARD
 
    set BOARD(doors,$to) $BOARD(doors,$from)
    set BOARD(tag,$to) $BOARD(tag,$from)
 }
 proc Index {row col} {
    if {$row eq "extra" || $col eq "extra"} { return "extra"}
    if {$row eq "save" || $col eq "save"} { return "save"}
    return "$row,$col"
 }
 proc DoShift {tags dx dy {fast 0} {soFar 0}} {
    set dd [expr {$fast ? 3*$::S(step) : $::S(step)}]
    set max [expr {$::S(sz) + $::S(pad)}]
    if {$soFar >= $max} { set ::S(vwait) 1 ; return}
    incr soFar $dd
    if {$soFar > $max} { set dd [expr {$dd + $max - $soFar}]}
 
    set dxx [expr {$dd*$dx}]
    set dyy [expr {$dd*$dy}]
    foreach tag $tags {
        .c move $tag $dxx $dyy
    }
    after $::S(delay) [list DoShift $tags $dx $dy $fast $soFar]
 }
 proc MoveTileTo {id row col} {
    foreach {x1 y1} [.c coords $id] break
    foreach {x2 y2} [LocateTile $row $col] break
 
    set dx [expr {$x2 - $x1}]
    set dy [expr {$y2 - $y1}]
    .c move $id $dx $dy
    .c raise $id board
 }
 proc DrawPlayer {who row col} {
    global S COLORS
 
    .c delete player,$who
    set pad [expr {-$S(wall)-2}]
    foreach {x0 y0 x1 y1} [Expand [LocateTile $row $col] $pad] break
    DrawPlayerAt $x0 $y0 $x1 $y1 $COLORS(player,$who) player,$who
    .c move player,$who [expr {2*($who-1)}] 0
 }
 proc DrawPlayerAt {x0 y0 x1 y1 color tag {W .c}} {
    set w [expr {$x1 - $x0}]
    set h [expr {$y1 - $y0}]
 
    set xm [expr {($x1 + $x0)/2}]
    set ym [expr {($y1 + $y0)/2}]
 
    set w8 [expr {$h/8}]
    set cy [expr {$y0 + $w8}]
    set cxy [Expand [list $xm $cy $xm $cy] $w8]
 
    set mxy [list $xm $cy \
                 [expr {$xm-1*$w/4}] $ym \
                 [expr {$xm-1*$w/8}] $ym \
                 [expr {$xm-3*$w/8}] $y1 \
                 [expr {$xm+3*$w/8}] $y1 \
                 [expr {$xm+1*$w/8}] $ym \
                 [expr {$xm+1*$w/4}] $ym \
                 $xm $cy]
    $W create poly $mxy -tag $tag -fill $color -outline $color
    $W create oval $cxy -tag $tag -fill $color -outline $color
 }
 proc DrawGem {row col} {
    global S COLORS
 
    .c delete gem
    set pad [expr {-$S(wall)-2}]
    foreach {x0 y0 x1 y1} [Expand [LocateTile $row $col] $pad] break
    DrawGemAt ? $x0 $y0 $x1 $y1 $COLORS(gem) gem
 }
 proc DrawGemAt {which x0 y0 x1 y1 color tag {W .c}} {
    set D(0) {
        {3 0 3 3 0 3}
        {3 0 3 3 6 3}
        {3 6 3 3 0 3}
        {3 6 3 3 6 3}
    }
    set D(1) {
        {2 1 4 1 5 2 5 4 4 5 2 5 1 4 1 2}
        {0 1 1 0 2 1 1 2}
        {1 0 5 0 4 1 2 1}
        {0 1 1 2 1 4 0 5}
        {5 0 6 1 5 2 4 1}
        {1 4 2 5 1 6 0 5}
        {2 5 4 5 5 6 1 6}
        {6 1 6 5 5 4 5 2}
        {5 4 6 5 5 6 4 5}
    }
    set D(2) {
        {1 0 2 0 2 1 0 1}
        {3 6 0 1 2 1}
        {2 0 4 0 4 1 2 1}
        {3 6 2 1 4 1}
        {4 0 5 0 6 1 4 1}
        {3 6 4 1 6 1}
    }
    set D(3) {
        {1 0 2 2 0 1}
        {1 0 5 0 4 2 2 2}
        {0 1 2 2 2 4 0 5}
        {5 0 6 1 4 2}
        {2 2 4 2 4 4 2 4}
        {2 4 1 6 0 5}
        {6 1 6 5 4 4 4 2}
        {2 4 4 4 5 6 1 6}
        {4 4 6 5 5 6}
    }
    if {$which eq "?"} {
        set which [expr {int(rand() * [llength [array names D]])}]
    }
    if {$which != 0} {
        foreach {x0 y0 x1 y1} [Expand [list $x0 $y0 $x1 $y1] -2] break
    }
    for {set i 0} {$i < 7} {incr i} {           ;# Get every 1/6 interval
        set x($i) [expr {$x0 + $i * ($x1-$x0)/6}]
        set y($i) [expr {$y0 + $i * ($y1-$y0)/6}]
    }
 
    set idx -1
    set darken [expr {70 / [llength $D($which)]}]
    foreach coords $D($which) {
        incr idx
        set xy(x,$idx) {}
        foreach {a b} $coords {
            lappend xy(x,$idx) $x($a) $y($b)
        }
        set c [::tk::Darken $color [expr {110-$darken*$idx}]]
        $W create poly $xy(x,$idx) -fill $c -tag [list $tag gem$idx] \
            -outline black
    }
 }
 proc KillGem {} {
    foreach {x0 y0 x1 y1} [.c bbox gem] break
    set xrad [expr {($x1 - $x0)/2}]
    set yrad [expr {($y1 - $y0)/2}]
    set xm [expr {($x1 + $x0)/2}]
    set ym [expr {($y1 + $y0)/2}]
 
    while {1} {
        .c scale gem $xm $ym .95 .95
        update
        foreach {l . r} [.c bbox gem] break
        if {$r - $l < 15} break
        after 30
    }
    .c delete gem
    foreach step {.25 .5 .75} rad {1 2 3} {
        for {set theta 0} {$theta < 360} {incr theta 60} {
            set x [expr {$xm + $step*$xrad*cos($theta * $::PI/180)}]
            set y [expr {$ym + $step*$yrad*sin($theta * $::PI/180)}]
            set xy [Expand [list $x $y] $rad]
            .c create oval $xy -tag gem -fill $::COLORS(gem)
        }
        update
        after 30
        .c delete gem
    }
 }
 proc RandomGem {} {
    global S GEM PLAYERS COLORS
    set bad {}
    for {set who 0} {$who < $S(players)} {incr who} {
        lappend bad [join $PLAYERS($who) ","]
    }
 
    while {1} {
        set row [expr {int(rand() * $S(n))}]
        set col [expr {int(rand() * $S(n))}]
        set n [lsearch $bad "$row,$col"]
        if {$n == -1} break
    }
    set COLORS(gem) [LightColor]
    DrawGem $row $col
    set GEM "$row,$col"
 }
 proc Expand {xy d} {
    foreach {x0 y0 x1 y1} [concat $xy $xy] break
    return [list [expr {$x0-$d}] [expr {$y0-$d}] \
                [expr {$x1+$d}] [expr {$y1+$d}]]
 }
 proc MovePlayer {who dir {fast 0}} {
    global S PLAYERS BOARD DIR GEM
 
    if {$S(state) ne "move"} return
    NewState "moving"
 
    while {1} {
        foreach {row col} $PLAYERS($who) break
        foreach {drow dcol} $DIR($dir) break
 
        set row2 [expr {$row + $drow}]
        set col2 [expr {$col + $dcol}]
 
        # Check legal move: on board w/o a wall
        if {$row2 < 0 || $row2 >= $S(n)|| $col2 < 0 || $col2 >= $S(n)} break
        set door [string map {U t D b R r L l} [string range $dir 0 0]]
        if {[string first $door $BOARD(doors,$row,$col)] == -1} break
        set door [string map {t b b t r l l r} $door]
        if {[string first $door $BOARD(doors,$row2,$col2)] == -1} break
 
        DoShift player,$who $dcol $drow $fast
        vwait ::S(vwait)
 
        set PLAYERS($who) [list $row2 $col2]
 
        if {$GEM eq "$row2,$col2"} {
            NewState gem
            return
        }
        if {$S(key) eq "" || $S(key) eq "mouse"} break
        set dir $S(key)
    }
    NewState "move"
 }
 proc KeyPress {who how} {
    global S
 
    if {$how eq "release" && $S(key) eq $who} {
        set S(key) ""
    } elseif {$how eq "press" && $S(key) ne $who && $S(key) ne "mouse"} {
        set S(key) $who
        if {$S(state) eq "move"} {
            after 1 MovePlayer $S(turn) $who
        }
    }
 }
 #
 # Stippling w/ custom bitmaps seems to require the bmp to be saved in
 # the file system. Here we write the bmp file to the tmp directory.
 #
 proc GetBoxesBMP {} {
    global S
 
    set boxesBMP {
        #define boxes_width 11
        #define boxes_height 9
        static char boxes_bits = {
            0xff, 0x07, 0xff, 0x07, 0x60, 0x00, 0x60, 0x00, 0xff,
            0x07, 0xff, 0x07, 0x03, 0x00, 0x03, 0x00, 0x03, 0x00
        }
    }
    set bmpName "JLBoxes.bmp"
 
    if {[file exists $bmpName]} {
        set S(bmp) $bmpName
        return
    }
    switch $::tcl_platform(platform) {
        unix {
            set tmpdir /tmp   # or even $::env(TMPDIR), at times.
        } macintosh {
            set tmpdir $::env(TRASH_FOLDER)  ;# a better place?
        } default {
            set tmpdir [pwd]
            catch {set tmpdir $::env(TMP)}
            catch {set tmpdir $::env(TEMP)}
        }
    }
    set fname [file join $tmpdir $bmpName]
    if {[file exists $fname]} {
        set S(bmp) $fname
        return
    }
    catch {
        set fout [open $fname w]
        puts $fout $boxesBMP
        close $fout
    }
    if {[file exists $fname]} {
        set S(bmp) $fname
        return
    }
 
    set emsg "ERROR: cannot create brick bitmap"
    tk_messageBox -title $S(title) -icon error -message $emgs
    exit
 }
 proc BlinkArrows {cnt} {
    global S COLORS
 
    if {$S(state) ne "pick"} return
    if {[incr cnt] > 31} return
    set col [expr {$cnt & 1 ? $COLORS(arrow) : $COLORS(bg)}]
    .c itemconfig arrow -fill $col
    after $S(blink,[expr {$cnt & 1 ? "on" : "off"}]) [list BlinkArrows $cnt]
 }
 ##+##########################################################################
 #
 # LightColor -- returns a "light" color. A light color is one in which
 # the V value in the HSV color model is greater than .7. Since the V
 # value is the maximum of R,G,B we simply need at least one of R,G,B
 # must be greater than .7.
 #
 proc LightColor {} {
    set light [expr {255 * .7}]                 ;# Value threshold
    while {1} {
        set r [expr {int (255 * rand())}]
        set g [expr {int (255 * rand())}]
        set b [expr {int (255 * rand())}]
        if {$r > $light || $g > $light || $b > $light} break
    }
    return [format "\#%02x%02x%02x" $r $g $b]
 }
 proc RotateTile {} {
    global BOARD
 
    set BOARD(doors,extra) [string map {r b b l l t t r} $BOARD(doors,extra)]
    MakeTile $BOARD(tag,extra) [LocateTile extra extra] $BOARD(doors,extra)
 }
 
 set rotImage {
    R0lGODlhLgAqALMAABQWjJCQmMvMy0tKfwQDyayprO7t7nRzdCQmdHR2jwQC+wkHqi0rmdnb2ba4
    tvz+/CH5BAAAAAAALAAAAAAuACoAAwT/8MlJq7046827/2CYIchwBIL4OGzrvmwjGYtiKwsTyN+x
    EMCgcJiY1W43QMLwCRCQUGjx0ThGFQjHp2C93qaNpxcX+DgA469EIB4Tph3BIK0AI35pwqEJaEfh
    DwYCCQNdSARlHAZ9eFeAFA5zVwspG5I4hjaPFQd+NwMbAl0LmZsVAZkEWhmXN6RSHE5RoBiLUQgF
    aGocrTYLPBYOnqoPAgi7G8JRiRYJUQATDZKmF8ewF70KexMGA28ezlC0FtnMEwfUFmxQDBgMUQUX
    THGeC+5QBPEqElVQ9tjL9q3x1A7gtX3hkBRs9myeimzjKhQYpk+EqIDydCFBsC/brwwHeKJ8CzFx
    loZ1/ip2cJBKpcGUHs5ciYihgcZDB4BdaJAgE45KG0pOGlCgwTwDBgocuHnI3IYEnvwxYDCAQSMv
    NHnR2frJoQcDULm6GeAVRACmYnGk8yDN51igAtck6EMHwAG4cSkYcBCgqtUcVBMUKJu3sOHDiPNG
    AAA7
 }
 proc NewGame {} {
    foreach aid [after info] { after cancel $aid}
    MakeScoreArea
    NewBoard
    array set ::SCORE {0 0 1 0 2 0 3 0}
    set ::S(turn) [expr {$::S(players)-1}]
    NewState done
 }
 proc About {} {
    set msg "$::S(title) v$::S(version)\n\nby Keith Vetter\nNovember 2005\n"
    tk_messageBox -title "About $::S(title)" -message $msg
 }
 proc Help {} {
    global S
 
    catch {destroy .help}
    toplevel .help
    wm title .help "$S(title) Help"
 
    set t .help.t
    text $t -relief raised -wrap word -width 60 -height 23 \
        -padx 10 -pady 10 -cursor {}
    button .help.ok -text OK -width 8 -command {destroy .help}
    pack .help.ok -side bottom -pady 10
    pack $t -side top -expand 1 -fill both
 
    set bold "[font actual [$t cget -font]] -weight bold"
    set italic "[font actual [$t cget -font]] -slant italic"
    $t tag config title -justify center -foregr red -font "Arial 20 bold"
    $t tag configure title2 -justify center -font "Arial 12 bold"
    $t tag configure heading -font $bold
    $t tag configure n -lmargin1 10 -lmargin2 10
    $t tag configure bullet -lmargin1 20 -lmargin2 30
 
    $t insert end "$S(title)\n" title
    $t insert end "by Keith Vetter\n\n" title2
 
    $t insert end "Based on a children's game by Ravensburger.\n\n"
 
    set h "Ojective\n"
    set m "To be the first player to collect $S(goal) gems.\n\n"
    $t insert end $h heading $m n
 
    set h "Starting a New Game\n"
    set b "o Select Game->New Game\n"
    append b "o Select Game->Players to change the number of players\n\n"
    $t insert end $h heading $b bullet
 
    #Playing
    set h "Playing the Game\n"
    set m "The players rotate taking turns. A player's turn consists "
    append m "of two parts:\n"
    set b "1. Sliding a tile to change the maze.\n"
    append b "2. Moving the player to try to capture the gem.\n\n"
    set m2 "A players turn ends when:\n"
    set b2 "o The gem is captured.\n"
    append b2 "o The player presses the DONE button.\n\n"
    $t insert end $h heading $m n $b bullet $m2 n $b2 bullet
 
    $t config -state disabled
    focus $t
 }
 proc Winner {who} {
    global S COLORS
 
    foreach {x0 y0 x1 y1} [LocateTile [expr {$S(n)/2}] [expr {$S(n)/2-1}]] break
    DrawPlayerAt $x0 $y0 $x1 $y1 $COLORS(player,$who) win .c
    set ym [expr {($y1 + $y0)/2}]
    .c create text $x1 $ym -tag win -text "Wins!" -font {Times 42 bold} \
        -fill white -anchor w
    set xy [Expand [.c bbox win] 30]
    .c create rect $xy -fill black -outline white -width 10 -tag {win x}
    .c lower x win
    set S(msg) ""
 }
 proc BDown {who} {
    if {$::S(turn) != $who} return
    if {$::S(state) ne "move"} return
 
    set color [::tk::Darken $::COLORS(player,$who) 80]
    .c itemconfig player,$who -width 5 -outline $color
 }
 proc BMotion {who x y} {
    global S PLAYERS DIR2
 
    if {$S(turn) != $who} return
    if {$S(state) ne "move"} return
 
    foreach {row0 col0} $PLAYERS($who) break
    foreach {row1 col1} [Canvas2Tile [.c canvasx $x] [.c canvasy $y]] break
    set drow [expr {$row1-$row0}]
    set dcol [expr {$col1-$col0}]
 
    set drow [expr {$drow > 0 ? 1 : $drow < 0 ? -1 : 0}]
    set dcol [expr {$dcol > 0 ? 1 : $dcol < 0 ? -1 : 0}]
    if {$drow > 1 || $drow < -1} return
    if {$dcol > 1 || $dcol < -1} return
    if {$drow == 0 && $dcol == 0} return
    if {$drow != 0 && $dcol != 0} return
    set S(key) "mouse"
    MovePlayer $who $DIR2($drow,$dcol) 1
    set S(key) ""
 }
 proc BUp {who} {
    .c itemconfig player,$who -width 1 -outline $::COLORS(player,$who)
 }
 
 DoDisplay
 NewGame


----

[JM] I could not see the "Done" button, looks like it is in the bottom of the GUI, just out of sight, and of reach )-:

----

[Category Games]