mazeserver.tcl

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

#! /usr/local/bin/wish

proc chooseRandomItem {list} {
    lindex $list [expr {int([llength $list]*rand())}]
}
proc repeat {script until condition} {
    uplevel 1 $script
    while {![uplevel 1 [list expr $condition]]} {
	uplevel 1 $script
    }
}

set VERSION 1.2

# must be odd!
set WIDTH 31
set HEIGHT 31

set DEBUG [llength [info commands .]]

# Reduces the size of the log a lot!
set LOGBROADCASTS 0

# Magic adjustment parameter.  It corresponds to the probability that
# the next section of maze to be added will be connected to the one
# just added.  Larger values make maze creation slower and maze
# solution more difficult.  Smaller values make maze creation quicker,
# but the maze itself is easier to solve if you can figure out where
# the middle is.  (The effect on the time to create is non-linear,
# BTW.)  Mazes created by people feel like the mazes created when this
# parameter takes on large values, but the rest of the game is
# virtually unplayable at that setting...
set SHAPEMAGIC 0.75

catch {console show}
catch {
    wm title . "Maze Explorer Server: Version $VERSION"
    wm protocol . WM_DELETE_WINDOW {
	if {[info exist server]} {
	    catch {close $server}
	}
	exit
    }
}


# ----------------------------------------------------------------------

### DISPLAY MESSAGE GENERATION CODE ###

array set offset {
    L8  {7  -6} ll8 {7  -4} l8  {7 -2} m8  {7  0}
    r8  {7   2} rr8 {7   4} R8  {7  6}
    LL7 {6  -7} L7  {6  -5} ll7 {6 -3} l7  {6 -1}
    r7  {6   1} rr7 {6   3} R7  {6  5} RR7 {6  7}
    L6  {5  -6} ll6 {5  -4} l6  {5 -2} m6  {5  0}
    r6	{5   2} rr6 {5   4} R6  {5  6}
    L5  {4  -5} ll5 {4  -3} l5  {4 -1} R5  {4  5} rr5 {4  3} r5  {4  1}
    ll4 {3  -4} l4  {3  -2} m4  {3  0} r4  {3  2} rr4 {3  4}
    ll3 {2  -3} l3  {2  -1} rr3 {2  3} r3  {2  1}
    l2  {1  -2} m2  {1   0} r2  {1  2} l1  {0 -1} r1  {0  1}
}

# Map from offsets to avatars to display.
array set avshow {
    {0 -2} al1  {0 0}  am1  {0 2}  ar1
    {2 -4} aL2  {2 -2} al2  {2 0}  am2  {2 2}  ar2  {2 4} aR2
    {4 -6} Al3  {4 -4} aL3  {4 -2} al3  {4 0}  am3
    {4 2}  ar3  {4 4}  aR3  {4 6}  Ar3
    {6 -8} AL4  {6 -6} Al4  {6 -4} aL4  {6 -2} al4  {6 0} am4
    {6 2}  ar4  {6 4}  aR4  {6 6}  Ar4  {6 8}  AR4
}

foreach {pos tag} [array get avshow] {
    set dotshow(c$tag) $pos
}

proc getRelativePosition {viewpoint place} {
    global position direction
    foreach {x y} $position($viewpoint) {break}
    foreach {ax ay} $place {break}
    set dx [expr {$ax-$x}]
    set dy [expr {$ay-$y}]
    switch $direction($viewpoint) {
	n { return [list [expr {$y-$ay}] [expr {$ax-$x}]] }
	s { return [list [expr {$ay-$y}] [expr {$x-$ax}]] }
	w { return [list [expr {$x-$ax}] [expr {$y-$ay}]] }
	e { return [list [expr {$ax-$x}] [expr {$ay-$y}]] }
	default {
	    return -code error [format "bad direction (%s) for %s" \
		    $direction($viewpoint) $viewpoint]
	}
    }
}
proc getAbsolutePosition {viewpoint offset} {
    global position direction
    foreach {x y} $position($viewpoint) {break}
    foreach {deep side} $offset {break}
    switch $direction($viewpoint) {
	n { return [list [expr {$x+$side}] [expr {$y-$deep}]] }
	s { return [list [expr {$x-$side}] [expr {$y+$deep}]] }
	e { return [list [expr {$x+$deep}] [expr {$y+$side}]] }
	w { return [list [expr {$x-$deep}] [expr {$y-$side}]] }
	default {
	    return -code error [format "bad direction (%s) for %s" \
		    $direction($viewpoint) $viewpoint]
	}
    }
}

proc getShowAvatar {viewpoint who} {
    global position direction avshow DEBUG

    set avposn [getRelativePosition $viewpoint $position($who)]

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

    if {[info exist avshow($avposn)]} {
	return $avshow($avposn)
    }
}

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 getDotColours {viewpoint} {
    global dotshow lastcol
    set ret {}
    foreach {key off} [array get dotshow] {
	set p [getAbsolutePosition $viewpoint $off]
	if {[info exist lastcol($p)]} {
	    lappend ret $key $lastcol($p)
	} else {
	    lappend ret $key {}
	}
    }
    return $ret
}

proc getShowPlace {viewpoint} {
    global offset position direction DEBUG avatars avcolours

    foreach {x y} $position($viewpoint) {break}
    if {$DEBUG} {
	.maze tag remove pos($viewpoint) 1.0 end
	.maze tag add pos($viewpoint) [expr {$y+1}].$x
    }

    # Display the walls
    set show {}
    foreach wall [array names offset] {
	foreach {dx dy} [getDisplacement $direction($viewpoint) $wall] {break}
	if {[getat [expr {$x+$dx}] [expr {$y+$dy}]]} {
	    lappend show $wall
	}
    }
    set result [list $show]

    # Display the avatar
    array set avresults {}
    foreach avatar $avatars {
	if {$avatar == $viewpoint} {continue}
	set av [getShowAvatar $viewpoint $avatar]
	if {[string length $av]} {
	    set avresults($av) $avcolours($avatar)
	}
    }
    lappend result [array get avresults]

    # Display the compass
    lappend result $direction($viewpoint)

    # Display the dots
    lappend result [getDotColours $viewpoint]

    return $result
}

# ----------------------------------------------------------------------

### MAZE GENERATOR ###

set NumSpaces [expr {(($WIDTH-1)/2)*(($HEIGHT-1)/2)}]

proc makeWorkArea {} {
    global WIDTH HEIGHT MAZE DEBUG NumSpaces
    # no [string repeat] in Tcl 8.0
    for {set s ""; set i 0} {$i<$WIDTH} {incr i} {
	append s "#"
    }
    if {$DEBUG} {
	text .maze -width $WIDTH -height $HEIGHT -font {courier -6} \
		-takefocus 0 -borderwidth 0 -background [. cget -bg]
	.maze tag configure pos(me) -background black
    }
    for {set y 0;set i 1} {$i<$HEIGHT} {incr i; incr y} {
	if {$DEBUG} {
	    .maze insert end "$s\n"
	}
	## Fastest to use an array...
	for {set x 0} {$x<$WIDTH} {incr x} {set MAZE($x,$y) 1}
    }
    if {$DEBUG} {
	.maze insert end $s
    }
    for {set x 0} {$x<$WIDTH} {incr x} {set MAZE($x,$y) 1}
}
proc setat {x y {chr " "} {flag 0}} {
    global MAZE WIDTH DEBUG
    set MAZE($x,$y) $flag
    if {$DEBUG} {
	set idx [incr y].$x
	.maze delete $idx
	.maze insert $idx $chr
    }
}
proc getat {x y} {
    global WIDTH HEIGHT MAZE
    if {$x<0 || $y<0 || $x>=$WIDTH || $y>=$HEIGHT} { return 1 }
    set MAZE($x,$y)
}
proc setInitialPosition {x y} {
    global places activeplaces
    setat $x $y
    set pos [list $x $y]
    lappend places $pos
    set activeplaces($pos) {n s e w}
}

makeWorkArea
setInitialPosition [expr {2*($WIDTH/4)|1}] [expr {2*($HEIGHT/4)|1}]

proc gapto {x y dir} {
    global places activeplaces WIDTH HEIGHT
    if {[getat $x $y]} { return }
    switch $dir {
	n {
	    if {$y<=1 || ![getat $x [expr {$y-2}]]} { return }
	    setat $x [incr y -1]
	    setat $x [incr y -1]
	}
	s {
	    if {$y>=$HEIGHT-2 || ![getat $x [expr {$y+2}]]} { return }
	    setat $x [incr y]
	    setat $x [incr y]
	}
	e {
	    if {$x>=$WIDTH-2 || ![getat [expr {$x+2}] $y]} { return }
	    setat [incr x] $y
	    setat [incr x] $y
	}
	w {
	    if {$x<=1 || ![getat [expr {$x-2}] $y]} { return }
	    setat [incr x -1] $y
	    setat [incr x -1] $y
	}
	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} {
    pack .maze
    bindtags .maze {.maze . all}
    . configure -cursor watch
    update
}
proc tmmsg {script} {
    global DEBUG
    set secs [expr {[lindex [time {uplevel 1 $script}] 0] / 1e6}]
    set msg [format "%.3f seconds to build data model" $secs]
    if {!$DEBUG} {
	puts stdout ""
    }
    puts stdout "$msg"
}
proc makeMaze {} {
    global DEBUG
    while {[canMove]} {
	doMove
	if {!$DEBUG} {
	    puts -nonewline .
	    flush stdout
	}
	update idletasks
    }
}
tmmsg makeMaze
if {$DEBUG} {
    . configure -cursor {}
}
proc initDots {} {
    global lastcol places
    foreach place $places {
	set lastcol($place) black
    }
}

# ----------------------------------------------------------------------

### BASIC MOTION CODE ###

array set posoff {
    n {0 -1}   s {0 1}   e {1 0}   w {-1 0}
}
proc step {backward who} {
    global position direction posoff lastcol avcolours
    foreach {x y} $position($who) {break}