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