maze.tcl

是一个迷人的探险游戏。可以单独运行(maze.tcl) 或者以支持网络的客户端/服务器形式运行（其它3个文件

	default {
	    error "unknown direction \"$dir\""
	}
    }
    lappend places [list $x $y]
    set s [surrounded $x $y]
    if {[llength $s]} {
	set activeplaces([list $x $y]) $s
    }
}
proc surrounded {x y} {
    global WIDTH HEIGHT
    set s {}
    if {$x > 1		&& [getat [expr {$x-2}] $y]} {lappend s w}
    if {$y > 1		&& [getat $x [expr {$y-2}]]} {lappend s n}
    if {$x < $WIDTH-2	&& [getat [expr {$x+2}] $y]} {lappend s e}
    if {$y < $HEIGHT-2	&& [getat $x [expr {$y+2}]]} {lappend s s}
    return $s
}
set previousplace {-10 -10} ;# DEFINITELY BOGUS VALUE
proc canMove {} {
    global activeplaces WIDTH HEIGHT places previousplace NumSpaces
    foreach {px py} $previousplace {}
    set previousplace [lindex $places end]
    set newAP {}
    set flag 0
    foreach place [array names activeplaces] {
	foreach {x y} $place {}
	# if Euclidean distance between active places is more than 2,
	# they cannot interact except by way of an intermediate place.
	# Don't bother with sqrt() though as we don't need to know
	# what the actual distance between the places is...
	if {($px-$x)*($px-$x)+($py-$y)*($py-$y) > 4} {continue}
	set s [surrounded $x $y]
	if {[llength $s]} {
	    set activeplaces($place) $s
	} else {
	    unset activeplaces($place)
	}
    }
    return [expr {$NumSpaces > [llength $places]}]
}
proc doMove {} {
    global activeplaces places SHAPEMAGIC
    set place [lindex $places end]
    if {rand()>$SHAPEMAGIC || ![info exist activeplaces($place)]} {
	set place [chooseRandomItem [array names activeplaces]]
    }
    set d [chooseRandomItem $activeplaces($place)]
    gapto [lindex $place 0] [lindex $place 1] $d
}

if {$DEBUG} {
    place .maze -relx 1.0 -rely 0.5 -anchor e
    lower .maze
    wm geometry . [expr {300+[winfo reqwidth .maze]}]x300
    bindtags .maze {.maze . all}
}
. configure -cursor watch
update
proc tmmsg {script} {
    set secs [expr {[lindex [time {uplevel 1 $script}] 0] / 1e6}]
    tk_messageBox -message [format "%.3f seconds to build data model" $secs]
}
proc makeMaze {} {
    global NumSpaces places
    set mcol 0
    set x1 [set y1 [set x2 [set y2 0]]]
    while {[canMove]} {
	doMove
	set frac [expr {double([llength $places])/$NumSpaces}]
	.c itemconfigure msg -fill [format "#%0.2x0000" [incr mcol 2]] \
		-text [format "BUILDING MAZE %02d%%" [expr {int($frac*100)}]]
	foreach {x1 y1 x2 y2} [.c bbox msg] {}
	.c coords msgbg $x1 $y1 [expr {$x2*$frac+$x1*(1-$frac)}] $y2
	if {$mcol>=250} {
	    set mcol 0
	}
	update idletasks
    }
}
tmmsg makeMaze
.c delete msg
.c delete msgbg
. configure -cursor {}
if {$DEBUG} {
    .maze configure -state disabled
    wm geometry . 300x300
}

# ----------------------------------------------------------------------

### MOVE AROUND MAZE ###

.c create text 150 299 -anchor s -font {Helvetica -14} -fill white -tag msg

set position(me) [chooseRandomItem $places]
set direction(me) [chooseRandomItem {n s e w}]
set score 0

proc getDisplacement {dir wall} {
    global offset
    if {![info exist offset($wall)]} {
	error "unknown wall description \"$wall\""
    }
    foreach {offA offB} $offset($wall) {break}
    switch $dir {
	n {
	    return [list $offB [expr {-$offA}]]
	}
	s {
	    return [list [expr {-$offB}] $offA]
	}
	e {
	    return [list $offA $offB]
	}
	w {
	    return [list [expr {-$offA}] [expr {-$offB}]]
	}
	default {
	    error "unknown direction \"$dir\""
	}
    }
}

proc showAvatar {who} {
    global position direction avshow avcolour DEBUG

    foreach {x y} $position(me) {break}
    foreach {ax ay} $position($who) {break}
    set dx [expr {$ax-$x}]
    set dy [expr {$ay-$y}]

    switch $direction(me) {
	n { set df [expr {-$dy}]; set ds $dx }
	s { set df $dy; set ds [expr {-$dx}] }
	w { set df [expr {-$dx}]; set ds [expr {-$dy}] }
	e { set df $dx; set ds $dy }
    }
    set avposn [list $df $ds]

    if {[info exist avshow($avposn)]} {
	.c itemconfigure $avshow($avposn) -fill $avcolour($who) -outline white
    }

    if {$DEBUG} {
	.maze tag remove pos($who) 1.0 end
	.maze tag add pos($who) [incr ay].$ax
    }
}

proc showPlace {} {
    global walls position direction DEBUG avatars

    # Display the walls
    foreach {x y} $position(me) {break}
    set show {}
    foreach wall $walls {
	foreach {dx dy} [getDisplacement $direction(me) $wall] {break}
	if {[getat [expr {$x+$dx}] [expr {$y+$dy}]]} {
	    lappend show $wall
	}
    }
    showWalls $show

    # Display the avatar
    .c itemconfigure avatar -fill {} -outline {}
    foreach avatar $avatars {
	showAvatar $avatar
    }

    # Display the compass
    switch $direction(me) {
	s {.c coords compass 275 10 275 40}
	n {.c coords compass 275 40 275 10}
	w {.c coords compass 260 25 290 25}
	e {.c coords compass 290 25 260 25}
    }

    if {$DEBUG} {
	.maze tag remove pos(me) 1.0 end
	.maze tag add pos(me) [incr y].$x
    }
}

proc turn {way {who me}} {
    global direction
    set d [lsearch {n s e w} $direction($who)]
    switch $way {
	left {
	    set direction($who) [lindex {w e n s} $d]
	}
	right {
	    set direction($who) [lindex {e w s n} $d]
	}
	default {
	    error "bad way to turn \"$way\""
	}
    }
}
proc step {{who me} {backward 0}} {
    global position direction
    foreach {x y} $position($who) {break}
    set posoff {
	{ 0 -1}
	{ 0  1}
	{ 1  0}
	{-1  0}
    }
    foreach {dx dy} [lindex $posoff [lsearch {n s e w} $direction($who)]] {
	break
    }
    if {$backward} {
	set dx [expr {-$dx}]
	set dy [expr {-$dy}]
    }
    incr x $dx
    incr y $dy
    if {![getat $x $y]} {
	incr x $dx
	incr y $dy
	set position($who) [list $x $y]
    }
}

proc darken {colour {pr 0.9} {pg 0.9} {pb 0.9} {w .}} {
    foreach {r g b} [winfo rgb $w $colour] {break}
    set r [expr {int($r*$pr)}]
    set g [expr {int($g*$pg)}]
    set b [expr {int($b*$pb)}]
    format "#%0.4x%0.4x%0.4x" $r $g $b
}
proc lighten {colour {pr 0.9} {pg 0.9} {pb 0.9} {w .}} {
    foreach {r g b} [winfo rgb $w $colour] {break}
    set r [expr {int($r/$pr)}];set r [expr {$r>0xffff?0xffff:$r}]
    set g [expr {int($g/$pg)}];set g [expr {$g>0xffff?0xffff:$g}]
    set b [expr {int($b/$pb)}];set b [expr {$b>0xffff?0xffff:$b}]
    format "#%0.4x%0.4x%0.4x" $r $g $b
}

proc userAvatarInteraction {} {
    global places avatars position seeking fill score
    if {![info exist seeking]} {return}
    set mypos $position(me)
    if {$mypos == $position($seeking)} {
	set position($seeking) [chooseRandomItem $places]
	set seeking [chooseRandomItem $avatars]
	.c configure -background [ \
		darken [.c cget -background] 0.8 0.8 0.9]
	.c itemconfigure floor -fill [ \
		darken [.c itemcget floor -fill] 0.8 0.9 0.8]
	foreach {wall colour} [array get fill] {
	    set fill($wall) [darken $colour]
	}
	incr score 10
	showLCD $score
    }
    foreach avatar $avatars {
	if {$mypos == $position($avatar)} {
	    set position(me) [chooseRandomItem $places]
	    .c configure -background [ \
		    lighten [.c cget -background] 0.8 0.8 0.9]
	    .c itemconfigure floor -fill [ \
		    lighten [.c itemcget floor -fill] 0.8 0.9 0.8]
	    foreach {wall colour} [array get fill] {
		set fill($wall) [lighten $colour]
	    }
	    bell
	    incr score -10
	    showLCD $score
	}
    }
}

proc avatarAction {{who avatar}} {
    eval [chooseRandomItem {step step step {turn left} {turn right}}] $who
    userAvatarInteraction
    showPlace
    after 500 avatarAction $who
}

.c create oval 255 5 295 45 -fill yellow -outline blue -width 2
.c create line 0 0 0 0 -fill blue -arrow last -tags compass -width 3 \
	-capstyle round
showLCD $score

foreach {avatar colour} $avatarDefinitions {
    lappend avatars $avatar
    set avcolour($avatar) $colour
    if {$DEBUG} {
	.maze tag configure pos($avatar) -background $colour
    }
    set position($avatar) [chooseRandomItem $places]
    set direction($avatar) [chooseRandomItem {n s e w}]
    avatarAction $avatar
}

trace variable seeking w seekingUpdate
proc seekingUpdate {args} {
    global avcolour seeking
    .c itemconfigure msg -text "You are seeking the $avcolour($seeking) being"
}
set seeking [chooseRandomItem $avatars]

bind . <Left>  {turn left;  userAvatarInteraction; showPlace}
bind . <Right> {turn right; userAvatarInteraction; showPlace}
bind . <Up>    {step;       userAvatarInteraction; showPlace}
bind . <Down>  {step me 1;  userAvatarInteraction; showPlace}

focus -force .