mazeserver.tcl

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

    foreach {dx dy} $posoff($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]
	set lastcol($position($who)) $avcolours($who)
    }
}

array set turnmap {
    left,n w   left,s e   left,e n   left,w s
    right,n e  right,s w  right,e s  right,w n
}
proc turn {way who} {
    global direction turnmap
    set direction($who) $turnmap($way,$direction($who))
}

proc chooseUnusedPosition {} {
    global places position avatars
    repeat {
	set place [chooseRandomItem $places]
    } until {[empty $place]}
    return $place
}
proc empty {place} {
    global position avatars
    foreach avatar $avatars {
	if {$place == $position($avatar)} {
	    return 0
	}
    }
    return 1
}
proc chooseRandomDirection {} {
    chooseRandomItem {n s e w}
}

proc updateDisplays {} {
    global avatars dpys
    foreach a $avatars {
	set d [getShowPlace $a]
	if {![info exist dpys($a)] || [string compare $d $dpys($a)]} {
	    sendMessage $a display [set dpys($a) $d]
	}
    }
    flushChannels
}
proc ouch {who score} {
    sendMessage $who ouch [list $score]
}
proc bump {who score} {
    sendMessage $who bump [list $score]
}
proc target {who sought} {
    global avcolours
    if {[string length $sought]} {
	sendMessage $who target [list $avcolours($sought)]
    } else {
	sendMessage $who target {{}}
    }
}

proc selectTarget {actor} {
    global avatars seeking
    if {[llength $avatars] < 2} {
	set seeking($actor) {} ;# make sure next line succeeds
	unset seeking($actor)
	target $actor {}
    } else {
	repeat {
	    set seeking($actor) [chooseRandomItem $avatars]
	} until {$actor != $seeking($actor)}
	target $actor $seeking($actor)
    }
}

proc randomiseLocation {who {broadcastMessage 0}} {
    global position direction lastcol avcolours
    set position($who) [chooseUnusedPosition]
    set direction($who) [chooseRandomDirection]
    set lastcol($position($who)) $avcolours($who)
    if {$broadcastMessage} {
	broadcast "SystemManager" "$avcolours($who) has been teleported"
    }
}

proc interaction {actor} {
    global places avatars position seeking score direction
    if {![info exist seeking($actor)]} {
	# No other actors exist!
	return
    }
    set mypos $position($actor)
    if {$mypos == $position($seeking($actor))} {
	ouch $seeking($actor) [incr score($seeking($actor)) -10]
	randomiseLocation $seeking($actor) 1
	selectTarget $actor
	bump $actor [incr score($actor) 10]
    }
    foreach avatar $avatars {
	if {$avatar == $actor} {continue}
	if {$mypos == $position($avatar)} {
	    # Bad collision - penalise the actor by passing to the bumpee
	    ouch $actor [incr score($actor) -5]
	    randomiseLocation $actor 1
	    bump $avatar [incr score($avatar) 5]
	}
    }
}

# basic motion wrappers
proc forward {who} {
    step 0 $who
    interaction $who
    updateDisplays
}
proc backward {who} {
    step 1 $who
    interaction $who
    updateDisplays
}
proc left {who} {
    turn left $who
    interaction $who
    updateDisplays
}
proc right {who} {
    turn right $who
    interaction $who
    updateDisplays
}
proc broadcast {who message} {
    global avatars avcolours LOGBROADCASTS
    if {[info exist avcolours($who)]} {
	set c $avcolours($who)
	set m "${c}: ${message}"
    } else {
	set c white
	set m "${who}: ${message}"
    }
    if {$LOGBROADCASTS} {
	puts stdout "Broadcasting \"$message\" to [join $avatars ,]"
    }
    foreach a $avatars {
	sendMessage $a message [list $c $m]
    }
    flushChannels
}
proc printConsole {who message} {
    puts stdout "DEBUG: ${who}: $message"
}

set definedColours {red orange yellow green blue purple}
proc makeAvatar {name} {
    global avatars seeking position direction score avcolours
    global definedColours DEBUG

    # Choose colour, or throw an error if all the colours are taken
    array set used {}
    foreach a $avatars {
	set used($avcolours($a)) 1
    }
    set scr {return -code error "Too many people connected"}
    foreach col $definedColours {
	if {![info exist used($col)]} {
	    set scr [list set avcolours($name) $col]
	    break
	}
    }
    eval $scr
    sendMessage $name colour [list $avcolours($name)]

    randomiseLocation $name
    set score($name) 0

    # Broadcast to everyone except the client joining...
    broadcast "SystemManager" "$avcolours($name) has joined"

    lappend avatars $name
    if {[llength $avatars] <= 2} {
	foreach a $avatars {selectTarget $a}
    } elseif {[llength $avatars] > 2} {
	selectTarget $name
    }

    sendMessage $name message {white "Welcome to Maze Explorer"}

    updateDisplays

    if {$DEBUG} {
	foreach {x y} $position($name) {break}
	.maze tag configure pos($name) -background $col
	.maze tag add pos($name) [incr y].$x
    }

    return $col
}

# Used when a socket gets closed.
proc deleteAvatar {deleted} {
    global avatars seeking position direction score avcolours DEBUG lastcol

    set idx [lsearch $avatars $deleted]
    if {$idx < 0} {
	# Already gone!
	return
    }

    # remove from avatar list
    set avatars [lreplace $avatars $idx $idx]

    set col [list $avcolours($deleted)]

    # remove avatar-specific data
    unset score($deleted) avcolours($deleted) position($deleted) \
	    direction($deleted)
    catch {unset seeking($deleted)}

    # Remove memory of what places have been visited by the avatar
    foreach {key dcol} [array get lastcol] {
	if {"$dcol" == "$col"} {
	    unset lastcol($key)
	}
    }

    # stop others from looking for the avatar
    foreach a $avatars {
	sendMessage $a vanished $col
	if {$seeking($a) == $deleted} {
	    selectTarget $a
	}
    }

    if {$DEBUG} {
	.maze tag remove pos($deleted) 1.0 end
    }

    broadcast "SystemManager" "$col has left"

    updateDisplays
}

# ----------------------------------------------------------------------

### NETWORK CODE ###
proc sendMessage {key cmd arglist} {
    global chans nukelist
    set fid $chans($key)
    if {[catch {
	puts $fid [linsert $arglist 0 $cmd]
    }]} then {
	deleteAvatar $key
	lappend nukelist $key
    }
}
proc flushChannels {} {
    global chans nukelist
    foreach {key fid} [array get chans] {
	if {[catch {
	    flush $fid
	}]} then {
	    deleteAvatar $key
	    lappend nukelist $key
	}
    }
}

proc evalKill args {
    global nukelist errorInfo errorCode
    set nukelist {}
    set code [catch {uplevel 1 $args} msg]
    set ei $errorInfo; set ec $errorCode
    foreach key $nukelist {
	deleteConnection $key
    }
    return -code $code -errorinfo $ei -errorcode $ec $msg
}

proc deleteConnection {key} {
    global chans interps
    if {![info exist chans($key)]} {return}
    catch {fileevent $chans($key) readable {}} ;# Terminates assoc. fileevents
    catch {close $chans($key)}                 ;# Close the connection itself
    catch {interp delete $interps($key)}       ;# Removes execution context
    puts stdout "closed $chans($key) for $key"
    unset chans($key) interps($key)            ;# Remove global variables
}

proc handleIncomingMessage {name} {
    global chans interps
    if {[catch {
	gets $chans($name) msg
    } len] || $len < 0} then {
	deleteAvatar $name
	deleteConnection $name
	flushChannels
	return
    }
    evalKill catch {$interps($name) eval $msg}
}

proc makeRestrictedCommandContext {name} {
    global interps

    # Make *hyper*-restricted!
    set i [interp create -safe]
    set cs [$i eval info commands]
    $i eval [linsert [$i eval info globals] 0 unset]
    foreach c $cs {
	$i hide $c
    }

    # Install the commands that we do support
    foreach c {forward backward left right broadcast printConsole} {
	$i alias   $c   $c $name
    }
    set interps($name) $i
}

set sequence 1
proc connected {fid host port} {
    global chans sequence VERSION

    puts stdout "connection from ${host}:${port} on $fid"

    if {[catch {
	puts $fid "version $VERSION"
	flush $fid
    }]} then {
	puts "terminated connection to $fid in initialisation"
	close $fid
	return
    }

    set name avatar[incr sequence]

    makeRestrictedCommandContext $name
    set chans($name) $fid
    fileevent $fid readable [list handleIncomingMessage $name]

    # Set up game data structures and notify other players.
    set col [evalKill makeAvatar $name]
    puts stdout "allocated colour $col to $fid"
}

proc initServer {{serverport 0}} {
    global server VERSION
    puts stdout "creating server version $VERSION"
    set server [socket -server connected $serverport]
    foreach {addr host port} [fconfigure $server -sockname] {break}
    puts stdout "created server on ${host}:${port}"
}

proc initVars {} {
    foreach varname {
	chans interps seeking position direction score avcolours dpys
    } {
	global $varname
	set ${varname}() {}
	unset ${varname}()
    }
    foreach varname {
	avatars
    } {
	global $varname
	set $varname [list]
    }
}

initVars
eval initServer $argv
vwait ForEverAndEverAmen