uniquename 2013aug01This game deserves an image to show what everyone is talking about here.
##+##########################################################################
#
# Labyrinth.tcl -- Plays Junior Labyrinth
# by Keith Vetter, Nov 2005
#
package require Tk
set S(title) "Junior Labyrinth"
set S(version) "1.02"
set S(sz) 65 ;# Tile size: 100, For screen resolution 1024x768: 65
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(csize) [expr {2*$S(m) + $S(bsize)}]
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}]
set S(lastShift) {0 0}
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 green3 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 $S(csize) -bd 0 -bg $COLORS(bg)
ShadedText .title [expr {$S(csize)/2}] 10 $COLORS(txt) black \
-font {Times 42 bold} -anchor n -tag title -text $S(title)
.title config -height [lindex [.title bbox title] 3]
canvas .c -width $S(csize) -height $S(csize) -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 24 -padx 24 \
-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 [list arrow a$row,$col] \
-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) -offset n
}
}
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 HideLastArrow {} {
foreach {row col} $::S(lastShift) break
if {$row == -1 || $row eq $::S(n)} {
set row [expr {$row == -1 ? $::S(n) : -1}]
} else {
set col [expr {$col == -1 ? $::S(n) : -1}]
}
.c lower a$row,$col
}
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
HideLastArrow
.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
set ::S(lastShift) [list $row $col]
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 "Objective\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
returnJM 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".KPV Added AvL's two suggestions. Started to add code to automatically config the size but the numbers weren't adding up and I gave up.HJG v1.02: Changed the green of player 2 to have a bit more contrast against the background.
