mazeclient.tcl

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

	    # Rescale colour according to distance
	    .c itemconfigure $t -fill [scaleDistance $colourscale($t) $c \
		    $r2 $g2 $b2  $r3 $g3 $b3] ;# Saved calculations!
	} else {
	    .c itemconfigure $t -fill {}
	}
    }
}

proc makeMsgArea {} {
    global msgs FONT

    .c create text 150 299 -anchor s -font $FONT -fill white -tag seeking
    foreach {? y1 ? y2} [.c bbox seeking] {break}
    set dy [expr {$y2-$y1+1}]
    set y [expr {299-$dy}]
    foreach i {0 1 2 3 4 5 6 7} {
	.c create text 150 $y -anchor s -font $FONT -tag msg$i
	set msgs($i) [list -fill white -text {}]
	set y [expr {$y-$dy}]
    }
}
proc addMsg {colour message} {
    global msgs removeId
    foreach i {7 6 5 4 3 2 1} ii {6 5 4 3 2 1 0} {
	set msgs($i) $msgs($ii)
    }
    set msgs(0) [list -fill $colour -text $message]
    foreach i {0 1 2 3 4 5 6 7} {
	eval .c itemconfigure msg$i $msgs($i)
    }
    after cancel $removeId
    set removeId [after 15000 removeMsg]
}
proc removeMsg {} {
    global removeId msgs
    foreach i {7 6 5 4 3 2 1 0} {
	set m $msgs($i)
	if {[string length [lindex $m 3]]} {
	    set msgs($i) [lreplace $m 3 3 {}]
	    eval .c itemconfigure msg$i $msgs($i)
	    set removeId [after 7500 removeMsg]
	    return
	}
    }
}
set removeId N*O*N*E*X*I*S*T*A*N*T*T*I*M*E*R*E*V*E*N*T

makeWalls
makeAvatars
makeMsgArea

# ----------------------------------------------------------------------

### MOVE AROUND MAZE ###

proc makeCompass {} {
    global FONT
    set darkblue [darken blue 0.7 0.7 0.7]
    .c create oval 255 5 295 35 -width 2 \
	    -fill [darken yellow 0.7 0.7 0.7] \
	    -outline $darkblue
    .c create line 0 0 0 0 -fill [lighten blue 0.7 0.7 0.7] -tags compass \
	    -arrow last -width 4 -capstyle round
    set fb "$FONT bold"
    set s [expr {([font metrics $fb -linespace]-1)/2}]
    foreach {x y t} {275 5 N    275 35 S    255 20 W    295 20 E} {
	.c create oval \
		[expr {$x-$s}] [expr {$y-$s}] [expr {$x+$s}] [expr {$y+$s}] \
		-fill $darkblue
	.c create text $x $y -anchor center -text $t -font $fb \
		-fill [lighten red 0.7 0.7 0.7] -tags compasstext
    }
    .c raise compass
    .c raise compasstext
}
makeCompass
proc showCompass {dir} {
    switch $dir {
	s {.c coords compass 275 15 275 30}
	n {.c coords compass 275 25 275 10}
	w {.c coords compass 265 20 290 20}
	e {.c coords compass 285 20 260 20}
    }
}

bind .e <Left>  {left;break}
bind .e <Right> {right;break}
bind .e <Up>    {forward;break}
bind .e <Down>  {backward;break}
bind .e <Escape> {.e delete 0 end}
bind .e <Return> {
    if {[string length [.e get]]} {
	broadcast [.e get]
	.e delete 0 end
    }
}

focus -force .e

# ----------------------------------------------------------------------

### NETWORK HANDLERS ###

## Incoming Messages
# display {wall wall ...} {avtype avcol avtype avcol ...} direction
# ouch newScore
# bump newScore
# target colour
# message colour messageString
# colour colour
# vanished colour

## Outgoing Messages
# forward
# backward
# left
# right
# broadcast messageString

proc forward {} {
    global socket
    if {[string length $socket]} {
	puts $socket "forward"
    }
}
proc backward {} {
    global socket
    if {[string length $socket]} {
	puts $socket "backward"
    }
}
proc left {} {
    global socket
    if {[string length $socket]} {
	puts $socket "left"
    }
}
proc right {} {
    global socket
    if {[string length $socket]} {
	puts $socket "right"
    }
}
proc broadcast {message} {
    global socket
    set message [lindex [split [string trim $message] "\n"] 0]
    if {[string length $socket]} {
	puts $socket [list "broadcast" $message]
    }
}
proc printConsole {message} {
    global socket
    if {[string length $socket]} {
	foreach line [split $message "\n"] {
	    puts $socket [list "printConsole" $line]
	}
    }
}

proc MSG_display {arg} {
    foreach {walls avs dir dots} $arg {break}
    # Update our display with walls $walls, avatars $avs, direction $dir,
    # and dot colouring $dots
    showWalls   $walls
    showDots    $dots
    showAvatars $avs
    showCompass $dir
}
proc MSG_ouch {arg} {
    set score [lindex $arg 0]
    # We hit something we shouldn't

    global fill
    .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]
    }
    catch {bell}
    showLCD $score
}
proc MSG_bump {arg} {
    set score [lindex $arg 0]
    # We hit something we should

    global fill
    .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]
    }
    showLCD $score
}
proc MSG_target {arg} {
    set col [lindex $arg 0]
    # We are seeking avatar $col

    if {[string length $col]} {
	.c itemconfigure seeking -text "You are seeking the $col being"
    } else {
	.c itemconfigure seeking -text "There is no-one to seek right now"
    }
}
proc MSG_message {arg} {
    foreach {col msg} $arg {break}
    # Avatar $col has sent message $msg

    puts stdout "message $col $msg"
    addMsg $col $msg
}
proc MSG_colour {arg} {
    set col [lindex $arg 0]
    # Our colour is $col

    wm title . "Maze Explorer Client: $col"
    showLCD 0
}
proc MSG_vanished {arg} {
    set col [lindex $arg 0]
    # Avatar $col has vanished from the server

    ## DO NOTHING ABOUT THIS ONE FOR NOW...
    puts stdout "vanished $col"
}
proc MSG_version {arg} {
    set ver [lindex $arg 0]
    global VERSION socket
    # Use [package vsatisfies] instead??
    if {[string compare $ver $VERSION]} {
	catch {close $socket}
	catch {
	    tk_messageBox -message "mismatched versions: $ver and $VERSION"
	}
	set socket {}
	return
    }
}

proc rcvMsg {} {
    global socket
    if {[gets $socket line] < 0} {
	close $socket
	set socket {}
	return
    }
    #puts stdout $line
    if {[catch {
	regsub -all {[^a-z]} [lindex $line 0] {} cmd
	set arg [lrange $line 1 end]
	MSG_$cmd $arg
    } msg]} {
	printConsole $::errorInfo
	bgerror $msg
    }
}

proc runClient {serverhost serverport} {
    global socket
    set socket [socket $serverhost $serverport]
    fconfigure $socket -buffering line
    fileevent $socket readable rcvMsg
    wm protocol . WM_DELETE_WINDOW {
	# Don't just delete the window...
	catch {close $socket}
	exit
    }
    vwait socket
    after 1500 exit
}

#console show
runClient $HOSTNAME $PORTNUMBER