[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.

[AK]: I described the rules I know on the [Shifting Maze] page.

----
 ##+##########################################################################
 #
 # 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 )-:

[KPV] The "Done" button only appears after you've slide a tile. It appears in the 
same spot that the extra tile is located. The whole gui is based off the '''S(sz)'''
and with it set to 100, the whole GUI is 922 pixels high. If that's too tall, just
set that value top something smaller.

[Brian Theado] - Thanks for sharing this!  My daughter and I have played this many times already and she loves it.  My screen resolution is 1024x768 and a value of '''S(sz)=65''' works well.

[AvL] Cute!  Btw, one of the original rules (at least for the non-junior
versions) is, that you must not do the previous move in the opposite direction.
(you may still do it in the same direction). If this rule makes sense in the
junior-version, then the arrow where previously a tile went out of the board 
would have to be "disabled".

...and btw., the stipple-pattern on each tile could be moved along with the tile 
using an "-offset".
----

[Category Games]