#!/usr/local/bin/tclsh


###
#
# MUDFEST, Copyright 2001, 2002 Michael A. Cleverly
#
set RCSID {@(#) $Id: mudfest.tcl,v 1.40 2002/08/04 17:11:40 michael Exp $}
#
###

# Run in debug mode?
if {![info exists debug_p]} {
    set debug_p 0
}

if {$debug_p} { 
    set autokill [after 10000 exit] 
}

if {![info exists script]} {
    set script [file join [pwd] [info script]]
}


################################################################################
#                                                                              #
# Mudfest makes use of a couple of (pure) Tcl packages; we could simply        #
# package require them, but then everyone we distributed mudfest to would      #
# need to also download those packages also.  So, instead, we simply include   #
# them inline here.  Our actual client code follows below.                     #
#                                                                              #
################################################################################


# irc.tcl --
#
#	irc implementation for Tcl.
#
# Copyright (c) 2001 by David N. Welton <davidw@dedasys.com>.
# This code may be distributed under the same terms as Tcl.
#

package provide irc 0.1

namespace eval irc {
    variable conn

    # configuration information
    set config(debug) 0

    # counter used to differentiate connections
    set conn 0
}

# irc::config -- 
#
# Set configuration options
#
# Arguments:
#
# key	name of the configuration option to change.
#
# value	value of the configuration option.

proc irc::config { key value } {
    variable config
    set config($key) $value
}

# irc::connection --

# Create an IRC connection namespace and associated commands.  Do not
# actually make the socket.

# Arguments:

# host	hostname to connect to

# port	port to use - usually 6667

proc irc::connection { host {port 6667} } {
    variable conn
    variable config

    # Create a unique namespace of the form irc$conn::$host

    set name [format "irc%s::%s" $conn $host]

    namespace eval $name {}

    set ${name}::conn $conn
    set ${name}::port $port

    namespace eval $name {
	set state 0
	set host [namespace tail [namespace current]]
	array set dispatch {}
    
	# ircsend --
	# send text to the IRC server

	proc ircsend { msg } {
	    variable sock
	    puts $sock "$msg"
	    if { $irc::config(debug) > 0 } {
		puts "ircsend: $msg"
	    }
	}

	# implemented user-side commands

	proc User { username hostname userinfo } {
	    ircsend "USER $username $hostname $username :$userinfo"
	}

	proc Nick { nick } {
	    ircsend "NICK $nick"
	}

	proc Ping { } {
	    ircsend "PING: [clock seconds]"
	}

	proc Join { chan } {
	    ircsend "JOIN $chan " 
	}

	proc Part { chan } {
	    ircsend "PART $chan"
	}

	proc Privmsg { target msg } {
	    ircsend "PRIVMSG $target :$msg"
	}

	# Connect --
	# Create the actual connection.

	proc Connect { } {
	    variable state 
	    variable sock 
	    variable host
	    variable conn
	    variable port
	    if { $state == 0 } {
		catch {
		    set sock [socket $host $port]
		}
		if { ! [info exists sock] } {
		    return -1
		}
		set state 1 
		fconfigure $sock -translation crlf
		fconfigure $sock -buffering line
		fileevent $sock readable [format "::irc::irc%s::%s::GetEvent" $conn $host ]
	    }
	    return 0
	}

	# DispatchServerEvent --

	# Dispatch event from server

	proc DispatchServerEvent { line } {
	    variable dispatch
	    set splitline [split $line]
	    set who [lindex $splitline 0]
	    set cmd [lindex $splitline 1]
	    set rest [lrange $splitline 2 end]
	    if { [info exists dispatch($cmd)] } {
		$dispatch($cmd) $who $rest
	    } else {
		$dispatch(defaultevent) $cmd $who $rest
	    }
	}

	# DispatchServerCmd --

	# Dispatch command from server

	proc DispatchServerCmd { line } {
	    variable dispatch
	    set splitline [split $line]
	    set action [lindex $splitline 0]
	    set rest [lrange $splitline 1 end]
	    if { [info exists dispatch($action)] } {
		$dispatch($action) $rest
	    } else {
		$dispatch(defaultcmd) $action $rest
	    }
	}

	# GetEvent --

	# Get a line from the server and send it on to
	# DispatchServerCmd/Event

	proc GetEvent { } {
	    variable sock
	    if { [eof $sock] } {
		if { [info exists dispatch(EOF)] } {
		    $dispatch(EOF)
		}
	    }
	    gets $sock line
	    if { [string index $line 0] == ":" } {
		DispatchServerEvent [string range $line 0 end]
	    } else { 
		DispatchServerCmd $line
	    }
	}

	# RegisterEvent --

	# Register an event in the dispatch table.

	# Arguments:
	
	# evnt: name of event as sent by IRC server.
	
	# cmd: proc to register as the event handler

	proc RegisterEvent { evnt cmd } {
	    variable dispatch
	    set dispatch($evnt) $cmd
	}

	# network --
	
	# Accepts user commands and dispatches them
	
	# Arguments:
	
	# cmd: command to invoke

	# args: arguments to the command

	proc network { cmd args } {
	    switch $cmd {
		connect { Connect }
		user { User [lindex $args 0] [lindex $args 1] [lindex $args 2] }
		nick { Nick [lindex $args 0] }
		join { Join [lindex $args 0] }
		privmsg { Privmsg [lindex $args 0] [lindex $args 1] }
		send { ircsend [lindex $args 0] }
		registerevent { RegisterEvent [lindex $args 0] [lindex $args 1] }
		default { }
	    }
	}
    }
    set returncommand [format "irc::irc%s::%s::network" $conn $host]
    incr conn
    return $returncommand
}



# graph.tcl --
#
#	Implementation of a graph data structure for Tcl.
#
# Copyright (c) 2000 by Andreas Kupries
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 

namespace eval ::struct {}

namespace eval ::struct::graph {
    # Data storage in the graph module
    # -------------------------------
    #
    # There's a lot of bits to keep track of for each graph:
    #	nodes
    #	node values
    #	node relationships (arcs)
    #   arc values
    #
    # It would quickly become unwieldy to try to keep these in arrays or lists
    # within the graph namespace itself.  Instead, each graph structure will
    # get its own namespace.  Each namespace contains:
    #	node:$node	array mapping keys to values for the node $node
    #	arc:$arc	array mapping keys to values for the arc $arc
    #	inArcs		array mapping nodes to the list of incoming arcs
    #	outArcs		array mapping nodes to the list of outgoing arcs
    #	arcNodes	array mapping arcs to the two nodes (start & end)
    
    # counter is used to give a unique name for unnamed graph
    variable counter 0

    # commands is the list of subcommands recognized by the graph
    variable commands [list	\
	    "arc"		\
	    "arcs"		\
	    "destroy"		\
	    "node"		\
	    "nodes"		\
	    "swap"		\
	    "walk"		\
	    ]

    variable arcCommands [list	\
	    "append"	\
	    "delete"	\
	    "exists"	\
	    "get"	\
	    "getall"	\
	    "insert"	\
	    "keys"	\
	    "keyexists"	\
	    "lappend"	\
	    "set"	\
	    "source"	\
	    "target"	\
	    "unset"	\
	    ]

    variable nodeCommands [list	\
	    "append"	\
	    "degree"	\
	    "delete"	\
	    "exists"	\
	    "get"	\
	    "getall"	\
	    "insert"	\
	    "keys"	\
	    "keyexists"	\
	    "lappend"	\
	    "opposite"	\
	    "set"	\
	    "unset"	\
	    ]

    # Only export one command, the one used to instantiate a new graph
    namespace export graph
}

# ::struct::graph::graph --
#
#	Create a new graph with a given name; if no name is given, use
#	graphX, where X is a number.
#
# Arguments:
#	name	name of the graph; if null, generate one.
#
# Results:
#	name	name of the graph created

proc ::struct::graph::graph {{name ""}} {
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "graph${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create graph"
    }

    # Set up the namespace
    namespace eval ::struct::graph::graph$name {

	# Set up the map from nodes to the arcs coming to them
	variable  inArcs
	array set inArcs {}

	# Set up the map from nodes to the arcs going out from them
	variable  outArcs
	array set outArcs {}

	# Set up the map from arcs to the nodes they touch.
	variable  arcNodes
	array set arcNodes {}

	# Set up a value for use in creating unique node names
	variable nextUnusedNode
	set nextUnusedNode 1

	# Set up a value for use in creating unique arc names
	variable nextUnusedArc
	set nextUnusedArc 1
    }

    # Create the command to manipulate the graph
    interp alias {} ::$name {} ::struct::graph::GraphProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::graph::GraphProc --
#
#	Command that processes all graph object commands.
#
# Arguments:
#	name	name of the graph object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::graph::GraphProc {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::graph::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::graph::_$cmd $name] $args
}

# ::struct::graph::_arc --
#
#	Dispatches the invocation of arc methods to the proper handler
#	procedure.
#
# Arguments:
#	name	name of the graph.
#	cmd	arc command to invoke
#	args	arguments to propagate to the handler for the arc command
#
# Results:
#	As of the invoked handler.

proc ::struct::graph::_arc {name cmd args} {

    # Split the args into command and args components
    if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } {
	variable arcCommands
	set optlist [join $arcCommands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }

    eval [list ::struct::graph::__arc_$cmd $name] $args
}

# ::struct::graph::__arc_delete --
#
#	Remove an arc from a graph, including all of its values.
#
# Arguments:
#	name	name of the graph.
#	args	list of arcs to delete.
#
# Results:
#	None.

proc ::struct::graph::__arc_delete {name args} {

    foreach arc $args {
	if { ![__arc_exists $name $arc] } {
	    error "arc \"$arc\" does not exist in graph \"$name\""
	}
    }

    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    foreach arc $args {
	foreach {source target} $arcNodes($arc) break ; # lassign

	unset arcNodes($arc)
	# FRINK: nocheck
	unset ::struct::graph::graph${name}::arc$arc

	# Remove arc from the arc lists of source and target nodes.

	set index            [lsearch -exact $outArcs($source) $arc]
	set outArcs($source) [lreplace       $outArcs($source) $index $index]

	set index            [lsearch -exact $inArcs($target)  $arc]
	set inArcs($target)  [lreplace       $inArcs($target)  $index $index]
    }

    return
}

# ::struct::graph::__arc_exists --
#
#	Test for existance of a given arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to look for.
#
# Results:
#	1 if the arc exists, 0 else.

proc ::struct::graph::__arc_exists {name arc} {
    return [info exists ::struct::graph::graph${name}::arcNodes($arc)]
}

# ::struct::graph::__arc_get --
#
#	Get a keyed value from an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for arc \"$arc\""
    }

    return $data($key)
}

# ::struct::graph::__arc_getall --
#
#	Get a serialized array of key/value pairs from an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#
# Results:
#	value	serialized array of key/value pairs.

proc ::struct::graph::__arc_getall {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "Wrong # arguments given to 'getall'"
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    return [array get data]
}

# ::struct::graph::__arc_keys --
#
#	Get a list of keys for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__arc_keys {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "Wrong # arguments given to 'keys'"
    }    

    upvar ::struct::graph::graph${name}::arc${arc} data

    return [array names data]
}

# ::struct::graph::__arc_keyexists --
#
#	Test for existance of a given key for a given arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    return [info exists data($key)]
}

# ::struct::graph::__arc_insert --
#
#	Add an arc to a graph.
#
# Arguments:
#	name		name of the graph.
#	source		source node of the new arc
#	target		target node of the new arc
#	args		arc to insert; must be unique.  If none is given,
#			the routine will generate a unique node name.
#
# Results:
#	arc		The name of the new arc.

proc ::struct::graph::__arc_insert {name source target args} {

    if { [llength $args] == 0 } {
	# No arc name was given; generate a unique one
	set arc [__generateUniqueArcName $name]
    } else {
	set arc [lindex $args 0]
    }

    if { [__arc_exists $name $arc] } {
	error "arc \"$arc\" already exists in graph \"$name\""
    }
    
    if { ![__node_exists $name $source] } {
	error "source node \"$source\" does not exist in graph \"$name\""
    }
    
    if { ![__node_exists $name $target] } {
	error "target node \"$target\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::inArcs    inArcs
    upvar ::struct::graph::graph${name}::outArcs   outArcs
    upvar ::struct::graph::graph${name}::arcNodes  arcNodes
    upvar ::struct::graph::graph${name}::arc${arc} data

    # Set up the new arc
    set data(data)       ""
    set arcNodes($arc) [list $source $target]

    # Add this arc to the arc lists of its source resp. target nodes.
    lappend outArcs($source) $arc
    lappend inArcs($target)  $arc

    return $arc
}

# ::struct::graph::__arc_set --
#
#	Set or get a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? ?value?
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_set {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name arc set $arc ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for arc \"$arc\""
	}
	return $data($key)
    }
}

# ::struct::graph::__arc_append --
#
#	Append a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_append {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name arc append $arc ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [append data($key) $value]
}

# ::struct::graph::__arc_lappend --
#
#	lappend a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_lappend {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name arc lappend $arc ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [lappend data($key) $value]
}

# ::struct::graph::__arc_source --
#
#	Return the node at the beginning of the specified arc.
#
# Arguments:
#	name	name of the graph object.
#	arc	arc to look up.
#
# Results:
#	node	name of the node.

proc ::struct::graph::__arc_source {name arc} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes
    return [lindex $arcNodes($arc) 0]
}

# ::struct::graph::__arc_target --
#
#	Return the node at the end of the specified arc.
#
# Arguments:
#	name	name of the graph object.
#	arc	arc to look up.
#
# Results:
#	node	name of the node.

proc ::struct::graph::__arc_target {name arc} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes
    return [lindex $arcNodes($arc) 1]
}

# ::struct::graph::__arc_unset --
#
#	Remove a keyed value from a arc.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify.
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name unset\
		$arc ?-key key?\""
    }

    upvar ::struct::graph::graph${name}::arc${arc} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::graph::_arcs --
#
#	Return a list of all arcs in a graph satisfying some
#	node based restriction.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	arcs	list of arcs

proc ::struct::graph::_arcs {name args} {

    if {[llength $args] == 0} {
	# No restriction, deliver all.

	upvar ::struct::graph::graph${name}::arcNodes arcNodes
	return [array names arcNodes]
    }

    # Get mode and node list

    set cond [lindex $args 0]
    set args [lrange $args 1 end]

    # Validate that the cond is good.
    switch -glob -- $cond {
	"-in" {
	    set cond "in"
	}
	"-out" {
	    set cond "out"
	}
	"-adj" {
	    set cond "adj"
	}
	"-inner" {
	    set cond "inner"
	}
	"-embedding" {
	    set cond "embedding"
	}
	default {
	    error "invalid restriction \"$cond\": should be -in, -out,\
		    -adj, -inner or -embedding"
	}
    }

    # Validate that there are nodes to use in the restriction.
    # otherwise what's the point?
    if {[llength $args] == 0} {
	set usage "$name arcs ?-in|-out|-adj|-inner|-embedding node node...?"
	error "no nodes specified: should be \"$usage\""
    }

    # Make sure that the specified nodes exist!
    foreach node $args {
	if { ![__node_exists $name $node] } {
	    error "node \"$node\" does not exist in graph \"$name\""
	}
    }

    # Now we are able to go to work
    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    set       arcs [list]
    array set coll  {}

    switch -exact -- $cond {
	in {
	    # Result is all arcs going to at least one node
	    # in the list of arguments.

	    foreach node $args {
		foreach e $inArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	out {
	    # Result is all arcs coming from at least one node
	    # in the list of arguments.

	    foreach node $args {
		foreach e $outArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	adj {
	    # Result is all arcs coming from or going to at
	    # least one node in the list of arguments.

	    foreach node $args {
		foreach e $inArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
		foreach e $outArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	inner {
	    # Result is all arcs running between nodes in the list.

	    array set group {}
	    foreach node $args {
		set group($node) .
	    }

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	embedding {
	    # Result is all arcs from -adj minus the arcs from -inner.
	    # IOW all arcs goint from a node in the list to a node
	    # which is *not* in the list

	    array set group {}
	    foreach node $args {
		set group($node) .
	    }

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	default {error "Can't happen, panic"}
    }

    return $arcs
}

# ::struct::graph::_destroy --
#
#	Destroy a graph, including its associated command and data storage.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	None.

proc ::struct::graph::_destroy {name} {
    namespace delete ::struct::graph::graph$name
    interp alias {} ::$name {}
}

# ::struct::graph::__generateUniqueArcName --
#
#	Generate a unique arc name for the given graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	arc	name of a arc guaranteed to not exist in the graph.

proc ::struct::graph::__generateUniqueArcName {name} {
    upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc
    while {[__arc_exists $name "arc${nextUnusedArc}"]} {
	incr nextUnusedArc
    }
    return "arc${nextUnusedArc}"
}

# ::struct::graph::__generateUniqueNodeName --
#
#	Generate a unique node name for the given graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	node	name of a node guaranteed to not exist in the graph.

proc ::struct::graph::__generateUniqueNodeName {name} {
    upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode
    while {[__node_exists $name "node${nextUnusedNode}"]} {
	incr nextUnusedNode
    }
    return "node${nextUnusedNode}"
}

# ::struct::graph::_node --
#
#	Dispatches the invocation of node methods to the proper handler
#	procedure.
#
# Arguments:
#	name	name of the graph.
#	cmd	node command to invoke
#	args	arguments to propagate to the handler for the node command
#
# Results:
#	As of the the invoked handler.

proc ::struct::graph::_node {name cmd args} {

    # Split the args into command and args components
    if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } {
	variable nodeCommands
	set optlist [join $nodeCommands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }

    eval [list ::struct::graph::__node_$cmd $name] $args
}

# ::struct::graph::__node_degree --
#
#	Return the number of arcs adjacent to the specified node.
#	If one of the restrictions -in or -out is given only
#	incoming resp. outgoing arcs are counted.
#
# Arguments:
#	name	name of the graph.
#	args	option, followed by the node.
#
# Results:
#	None.

proc ::struct::graph::__node_degree {name args} {

    if {([llength $args] < 1) || ([llength $args] > 2)} {
	error "wrong # args: should be \"$name node degree ?-in|-out| node\""
    }

    switch -exact -- [llength $args] {
	1 {
	    set opt {}
	    set node [lindex $args 0]
	}
	2 {
	    set opt  [lindex $args 0]
	    set node [lindex $args 1]
	}
	default {
	    error "Wrong # arguments given to 'degree'"
	}
    }

    # Validate the option.

    switch -exact -- $opt {
	{}   -
	-in  -
	-out {}
	default {
	    error "invalid option \"$opt\": should be -in or -out"
	}
    }

    # Validate the node

    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs

    switch -exact -- $opt {
	-in  {
	    set result [llength $inArcs($node)]
	}
	-out {
	    set result [llength $outArcs($node)]
	}
	{} {
	    set result [expr {[llength $inArcs($node)] \
		    + [llength $outArcs($node)]}]

	    # loops count twice, don't do <set> arithmetics, i.e. no union!
	    if {0} {
		array set coll  {}
		set result [llength $inArcs($node)]

		foreach e $inArcs($node) {
		    set coll($e) .
		}
		foreach e $outArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    incr result
		    set     coll($e) .
		}
	    }
	}
	default {error "Can't happen, panic"}
    }

    return $result
}

# ::struct::graph::__node_delete --
#
#	Remove a node from a graph, including all of its values.
#	Additionally removes the arcs connected to this node.
#
# Arguments:
#	name	name of the graph.
#	args	list of the nodes to delete.
#
# Results:
#	None.

proc ::struct::graph::__node_delete {name args} {

    foreach node $args {
	if { ![__node_exists $name $node] } {
	    error "node \"$node\" does not exist in graph \"$name\""
	}
    }

    upvar ::struct::graph::graph${name}::inArcs  inArcs
    upvar ::struct::graph::graph${name}::outArcs outArcs

    foreach node $args {
	# Remove all the arcs connected to this node
	foreach e $inArcs($node) {
	    __arc_delete $name $e
	}
	foreach e $outArcs($node) {
	    # Check existence to avoid problems with
	    # loops (they are in and out arcs! at
	    # the same time and thus already deleted)
	    if { [__arc_exists $name $e] } {
		__arc_delete $name $e
	    }
	}

	unset inArcs($node)
	unset outArcs($node)
	# FRINK: nocheck
	unset ::struct::graph::graph${name}::node$node
    }

    return
}

# ::struct::graph::__node_exists --
#
#	Test for existance of a given node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to look for.
#
# Results:
#	1 if the node exists, 0 else.

proc ::struct::graph::__node_exists {name node} {
    return [info exists ::struct::graph::graph${name}::inArcs($node)]
}

# ::struct::graph::__node_get --
#
#	Get a keyed value from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_get {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for node \"$node\""
    }

    return $data($key)
}

# ::struct::graph::__node_getall --
#
#	Get a serialized list of key/value pairs from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_getall {name node args} { 
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "Wrong # arguments given to 'getall'"
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    return [array get data]
}

# ::struct::graph::__node_keys --
#
#	Get a of keys from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_keys {name node args} { 
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { [llength $args] } {
	error "Wrong # arguments given to 'keys'"
    }

    upvar ::struct::graph::graph${name}::node${node} data

    return [array names data]
}

# ::struct::graph::__node_keyexists --
#
#	Test for existance of a given key for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    return [info exists data($key)]
}

# ::struct::graph::__node_insert --
#
#	Add a node to a graph.
#
# Arguments:
#	name		name of the graph.
#	args		node to insert; must be unique.  If none is given,
#			the routine will generate a unique node name.
#
# Results:
#	node		The namee of the new node.

proc ::struct::graph::__node_insert {name args} {

    if { [llength $args] == 0 } {
	# No node name was given; generate a unique one
	set node [__generateUniqueNodeName $name]
    } else {
	set node [lindex $args 0]
    }

    if { [__node_exists $name $node] } {
	error "node \"$node\" already exists in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::inArcs      inArcs
    upvar ::struct::graph::graph${name}::outArcs     outArcs
    upvar ::struct::graph::graph${name}::node${node} data

    # Set up the new node
    set inArcs($node)  [list]
    set outArcs($node) [list]
    set data(data) ""

    return $node
}

# ::struct::graph::__node_opposite --
#
#	Retrieve node opposite to the specified one, along the arc.
#
# Arguments:
#	name		name of the graph.
#	node		node to look up.
#	arc		arc to look up.
#
# Results:
#	nodex	Node opposite to <node,arc>

proc ::struct::graph::__node_opposite {name node arc} {
    if {![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if {![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    # Node must be connected to at least one end of the arc.

    if {[string equal $node [lindex $arcNodes($arc) 0]]} {
	set result [lindex $arcNodes($arc) 1]
    } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} {
	set result [lindex $arcNodes($arc) 0]
    } else {
	error "node \"$node\" and arc \"$arc\" are not connected\
		in graph \"$name\""
    }

    return $result
}

# ::struct::graph::__node_set --
#
#	Set or get a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? ?value?
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_set {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name node set $node ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for node \"$node\""
	}
	return $data($key)
    }
}

# ::struct::graph::__node_append --
#
#	Append a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_append {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name node append $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [append data($key) $value]
}

# ::struct::graph::__node_lappend --
#
#	lappend a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_lappend {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name node lappend $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [lappend data($key) $value]
}

# ::struct::graph::__node_unset --
#
#	Remove a keyed value from a node.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify.
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::graph::__node_unset {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name unset\
		$node ?-key key?\""
    }

    upvar ::struct::graph::graph${name}::node${node} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::graph::_nodes --
#
#	Return a list of all nodes in a graph satisfying some restriction.
#
# Arguments:
#	name	name of the graph.
#	args	list of options and nodes specifying the restriction.
#
# Results:
#	nodes	list of nodes

proc ::struct::graph::_nodes {name args} {

    if {[llength $args] == 0} {
	# No restriction, deliver all.

	upvar ::struct::graph::graph${name}::inArcs inArcs
	return [array names inArcs]
    }

    # Get mode and node list

    set cond [lindex $args 0]
    set args [lrange $args 1 end]

    # Validate that the cond is good.
    switch -glob -- $cond {
	"-in" {
	    set cond "in"
	}
	"-out" {
	    set cond "out"
	}
	"-adj" {
	    set cond "adj"
	}
	"-inner" {
	    set cond "inner"
	}
	"-embedding" {
	    set cond "embedding"
	}
	default {
	    error "invalid restriction \"$cond\": should be -in, -out,\
		    -adj, -inner or -embedding"
	}
    }

    # Validate that there are nodes to use in the restriction.
    # otherwise what's the point?
    if {[llength $args] == 0} {
	set usage "$name nodes ?-in|-out|-adj|-inner|-embedding node node...?"
	error "no nodes specified: should be \"$usage\""
    }

    # Make sure that the specified nodes exist!
    foreach node $args {
	if { ![__node_exists $name $node] } {
	    error "node \"$node\" does not exist in graph \"$name\""
	}
    }

    # Now we are able to go to work
    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    set       nodes [list]
    array set coll  {}

    switch -exact -- $cond {
	in {
	    # Result is all nodes with at least one arc going to
	    # at least one node in the list of arguments.

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	out {
	    # Result is all nodes with at least one arc coming from
	    # at least one node in the list of arguments.

	    foreach node $args {
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	adj {
	    # Result is all nodes with at least one arc coming from
	    # or going to at least one node in the list of arguments.

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	inner {
	    # Result is all nodes from the list! with at least one arc
	    # coming from or going to at least one node in the list of
	    # arguments.

	    array set group {}
	    foreach node $args {
		set group($node) .
	    }

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	embedding {
	    # Result is all nodes with at least one arc coming from
	    # or going to at least one node in the list of arguments,
	    # but not in the list itself!

	    array set group {}
	    foreach node $args {
		set group($node) .
	    }

	    foreach node $args {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	default {error "Can't happen, panic"}
    }

    return $nodes
}

# ::struct::graph::_swap --
#
#	Swap two nodes in a graph.
#
# Arguments:
#	name	name of the graph.
#	node1	first node to swap.
#	node2	second node to swap.
#
# Results:
#	None.

proc ::struct::graph::_swap {name node1 node2} {
    # Can only swap two real nodes
    if { ![__node_exists $name $node1] } {
	error "node \"$node1\" does not exist in graph \"$name\""
    }
    if { ![__node_exists $name $node2] } {
	error "node \"$node2\" does not exist in graph \"$name\""
    }

    # Can't swap a node with itself
    if { [string equal $node1 $node2] } {
	error "cannot swap node \"$node1\" with itself"
    }

    # Swapping nodes means swapping their labels, values and arcs
    upvar ::struct::graph::graph${name}::outArcs      outArcs
    upvar ::struct::graph::graph${name}::inArcs       inArcs
    upvar ::struct::graph::graph${name}::arcNodes     arcNodes
    upvar ::struct::graph::graph${name}::node${node1} node1Vals
    upvar ::struct::graph::graph${name}::node${node2} node2Vals

    # Redirect arcs to the new nodes.

    foreach e $inArcs($node1) {
	set arcNodes($e) [lreplace $arcNodes($e) end end $node2]
    }
    foreach e $inArcs($node2) {
	set arcNodes($e) [lreplace $arcNodes($e) end end $node1]
    }
    foreach e $outArcs($node1) {
	set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2]
    }
    foreach e $outArcs($node2) {
	set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1]
    }

    # Swap arc lists

    set tmp            $inArcs($node1)
    set inArcs($node1) $inArcs($node2)
    set inArcs($node2) $tmp

    set tmp             $outArcs($node1)
    set outArcs($node1) $outArcs($node2)
    set outArcs($node2) $tmp

    # Swap the values
    set   value1        [array get node1Vals]
    unset node1Vals
    array set node1Vals [array get node2Vals]
    unset node2Vals
    array set node2Vals $value1

    return
}

# ::struct::graph::_walk --
#
#	Walk a graph using a pre-order depth or breadth first
#	search. Pre-order DFS is the default.  At each node that is visited,
#	a command will be called with the name of the graph and the node.
#
# Arguments:
#	name	name of the graph.
#	node	node at which to start.
#	args	additional args: ?-order pre|post|both? ?-type {bfs|dfs}?
#		-command cmd
#
# Results:
#	None.

proc ::struct::graph::_walk {name node args} {
    set usage "$name walk $node ?-dir forward|backward?\
	    ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd"

    if {[llength $args] > 8 || [llength $args] < 2} {
	error "wrong # args: should be \"$usage\""
    }

    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    # Set defaults
    set type  dfs
    set order pre
    set cmd   ""
    set dir   forward

    # Process specified options
    for {set i 0} {$i < [llength $args]} {incr i} {
	set flag [lindex $args $i]
	incr i
	if { $i >= [llength $args] } {
	    error "value for \"$flag\" missing: should be \"$usage\""
	}
	switch -glob -- $flag {
	    "-type" {
		set type [string tolower [lindex $args $i]]
	    }
	    "-order" {
		set order [string tolower [lindex $args $i]]
	    }
	    "-command" {
		set cmd [lindex $args $i]
	    }
	    "-dir" {
		set dir [string tolower [lindex $args $i]]
	    }
	    default {
		error "unknown option \"$flag\": should be \"$usage\""
	    }
	}
    }
    
    # Make sure we have a command to run, otherwise what's the point?
    if { [string equal $cmd ""] } {
	error "no command specified: should be \"$usage\""
    }

    # Validate that the given type is good
    switch -glob -- $type {
	"dfs" {
	    set type "dfs"
	}
	"bfs" {
	    set type "bfs"
	}
	default {
	    error "invalid search type \"$type\": should be dfs, or bfs"
	}
    }
    
    # Validate that the given order is good
    switch -glob -- $order {
	"both" {
	    set order both
	}
	"pre" {
	    set order pre
	}
	"post" {
	    set order post
	}
	default {
	    error "invalid search order \"$order\": should be both,\
		    pre or post"
	}
    }

    # Validate that the given direction is good
    switch -glob -- $dir {
	"forward" {
	    set dir -out
	}
	"backward" {
	    set dir -in
	}
	default {
	    error "invalid search direction \"$dir\": should be\
		    forward or backward"
	}
    }

    # Do the walk

    set st [list ]
    lappend st $node
    array set visited {}

    if { [string equal $type "dfs"] } {
	if { [string equal $order "pre"] } {
	    # Pre-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex   $st end]
		set st   [lreplace $st end end]

		# Evaluate the command at this node
		set cmdcpy $cmd
		lappend cmdcpy enter $name $node
		uplevel 2 $cmdcpy

		set visited($node) .

		# Add this node's neighbours (according to direction)
		#  Have to add them in reverse order
		#  so that they will be popped left-to-right

		set next [_nodes $name $dir $node]
		set len  [llength $next]

		for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
		    set nextnode [lindex $next $i]
		    if {[info exists visited($nextnode)]} {
			# Skip nodes already visited
			continue
		    }
		    lappend st $nextnode
		}
	    }
	} elseif { [string equal $order "post"] } {
	    # Post-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex $st end]

		if {[info exists visited($node)]} {
		    # Second time we are here, pop it,
		    # then evaluate the command.

		    set st [lreplace $st end end]

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy leave $name $node
		    uplevel 2 $cmdcpy
		} else {
		    # First visit. Remember it.
		    set visited($node) .
	    
		    # Add this node's neighbours.
		    set next [_nodes $name $dir $node]
		    set len  [llength $next]

		    for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
			set nextnode [lindex $next $i]
			if {[info exists visited($nextnode)]} {
			    # Skip nodes already visited
			    continue
			}
			lappend st $nextnode
		    }
		}
	    }
	} else {
	    # Both-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex $st end]

		if {[info exists visited($node)]} {
		    # Second time we are here, pop it,
		    # then evaluate the command.

		    set st [lreplace $st end end]

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy leave $name $node
		    uplevel 2 $cmdcpy
		} else {
		    # First visit. Remember it.
		    set visited($node) .

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy enter $name $node
		    uplevel 2 $cmdcpy
	    
		    # Add this node's neighbours.
		    set next [_nodes $name $dir $node]
		    set len  [llength $next]

		    for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
			set nextnode [lindex $next $i]
			if {[info exists visited($nextnode)]} {
			    # Skip nodes already visited
			    continue
			}
			lappend st $nextnode
		    }
		}
	    }
	}

    } else {
	if { [string equal $order "pre"] } {
	    # Pre-order Breadth first search
	    while { [llength $st] > 0 } {
		set node [lindex $st 0]
		set st   [lreplace $st 0 0]
		# Evaluate the command at this node
		set cmdcpy $cmd
		lappend cmdcpy enter $name $node
		uplevel 2 $cmdcpy
	    
		set visited($node) .

		# Add this node's neighbours.
		foreach child [_nodes $name $dir $node] {
		    if {[info exists visited($child)]} {
			# Skip nodes already visited
			continue
		    }
		    lappend st $child
		}
	    }
	} else {
	    # Post-order Breadth first search
	    # Both-order Breadth first search
	    # Haven't found anything in Knuth
	    # and unable to define something
	    # consistent for myself. Leave it
	    # out.

	    error "unable to do a ${order}-order breadth first walk"
	}
    }
    return
}

# ::struct::graph::Union --
#
#	Return a list which is the union of the elements
#	in the specified lists.
#
# Arguments:
#	args	list of lists representing sets.
#
# Results:
#	set	list representing the union of the argument lists.

proc ::struct::graph::Union {args} {
    switch -- [llength $args] {
	0 {
	    return {}
	}
	1 {
	    return [lindex $args 0]
	}
	default {
	    foreach set $args {
		foreach e $set {
		    set tmp($e) .
		}
	    }
	    return [array names tmp]
	}
    }
}



################################################################################
#                                                                              #
#                      BEGINNING OF ACTUAL MUDFEST CODE                        #
#                                                                              #
################################################################################



###
#
# Determine what mode to run in
#
###


if {$::tcl_platform(platform) == "unix"} {
    switch -glob -- [file tail [info nameofexecutable]] {
        wish*   { set ::mode gui }
        tclkitsh -
        tclkitck -
        cwsh*   { set ::mode tui }
        default { puts stderr "Should be invoked through shell script only, not via [info nameofexecutable]" 
                  exit }
    }
} else {
    set ::mode gui
    if {![info exists ::tcl_platform(user)] || 
        ![string length [string trim $::tcl_platform(user)]]} {
        set ::tcl_platform(user) $::tcl_platform(platform)
    }
}



###
#
# Connection stubs
#
###


if {![info exists conn]} {
    array set conn {
        mud ""
        irc ""
        channels ""
        last_ping ""
        nick ""
    }
}


###
#
# Handle basic ANSI colors (needed before text widget is created)
# Courtesy: http://mini.net/tcl/1143.html
#
###

namespace eval ansicolor {
    namespace export +

    variable map {
         bold 1 light 2 blink 5 invert 7
         black 30 red 31 green 32 yellow 33 blue 34 magenta 35 cyan 36 white 37
         Black 40 Red 41 Green 42 Yellow 43 Blue 44 Magenta 45 Cyan 46 White 47
    }

    proc + {args} {
        variable map
        set t 0

        foreach i $args {
            set ix [lsearch -exact $map $i]
            if {$ix>-1} {lappend t [lindex $map [incr ix]]}
        }

        return "\033\[[join $t {;}]m"
    }

    proc get {code} {
        variable map
        set res [list]

        foreach i [split $code ";"] {
            set ix [lsearch -exact $map $i]
            if {$ix>-1} {lappend res [lindex $map [incr ix -1]]}
        }

        return $res
    }

    proc text {w args} {
        variable $w.tags ""
        eval ::text $w $args
        rename ::$w ::_$w

        proc ::$w {cmd args} {
            regsub -all @ {([^@]*)(@\[([^m]+)m)} \x1b re
            set self [lindex [info level 0] 0]
            if {$cmd=="insert"} {
                foreach {pos text tags} $args break
                while {[regexp $re $text -> before esc code]} {
                    _$self insert $pos $before [set ansicolor::$self.tags]
                    set ansicolor::$self.tags [ansicolor::get $code]
                    regsub $re $text "" text
                }
                _$self insert $pos $text [concat $self.tags $tags]
            } else {
                uplevel 1 _$self $cmd $args
            }
        }

        foreach i {black red green yellow blue magenta cyan white} {
                _$w tag configure $i -foreground $i
        }

        foreach i {Black Red Green Yellow Blue Magenta Cyan White} {
                _$w tag configure $i -background [string tolower $i]
        }

        return $w
    }
}



###
#
# Setup user interface
#
###

if {![info exists ui]} {
    array set ui {
        entry    ""
        history  {}
        pos      -1
        TIME     "TIME: --:-- (~--:--)"
        HEALTH   "HEALTH: --- / ---"
        STATUS   "STATUS: Offline"
        VIEW     "VIEW: All"
        realtime "--:--"
        gametime "--:--"
        hp       "---"
        sp       "---"
        status   "Offline"
        view     "All"
        out,fg   white
        out,fg,gui cornsilk
        out,bg   black
        mud,fg   white
        mud,bg   black
        irc,fg   green
        irc,bg   black
        sys,fg   red
        sys,bg   black
        tcl,fg   magenta
        tcl,bg   black
        tui_box  {ulcorner hline urcorner vline lrcorner llcorner}
        colspan  4
        status_width 18
        buf_counter  0
        orig_scroll_bg  ""
        orig_scroll_abg ""
        alt_scroll_bg   red
        alt_scroll_abg  magenta
        gtime_synch_id  ""
        last_keystroke  0
        show_prompt_p   0
        tui_border_p    1
        echo            1
    }
}

# fix for lou's b&w xterm
if {[info exists env(TERM)] && 
    [string equal $env(TERM) "xterms"]} {
    foreach type_of_color [list out mud irc sys tcl] {
        set ui($type_of_color,fg) white
        set ui($type_of_color,bg) black
    }

    set ui(alt_scroll_bg) white
    set ui(alt_scroll_abg) white
    set ui(out,fg,gui) white
}


# Make sure we have a way to bail out of cwsh if we have to in an emergency
if {$mode == "tui"} {
    bind . <Control-c> exit
    bind . <Control-C> exit
}


proc enable {system option} {
    upvar #0 $system thing
    set thing(${option}_p) 1
}


proc disable {system option} {
    upvar #0 $system thing
    set thing(${option}_p) 0
}



#
# Users own .mudfestrc file
#

proc .mudfestrc {} {
    global tcl_platform

    if {$tcl_platform(platform) == "unix"} {
        set file ~/.mudfestrc
    } else {
        set file [file join ~ mudfest.rc]
    }
    
    if {[file exists $file] && [file readable $file]} {
        if {[info commands buffer->append] != ""} {
            if {[catch { source $file } result]} {
                buffer->append sys "Error loading $file:\n$result"
            } else {
                buffer->append sys "Loaded $file"
            }
        } else {
            catch { source $file }
        }
    }
}

# load their .mudfestrc
.mudfestrc

#
# Output Buffer 
#

if {[info commands .buffer] == ""} {
    switch $mode {
        gui { frame .buffer -borderwidth 1 }
        tui { frame .buffer -border $ui(tui_box) }
    }
    
    scrollbar .buffer.scroll -command { .buffer.text yview }
    set ui(orig_scroll_bg)  [.buffer.scroll cget -background]
    set ui(orig_scroll_abg) [.buffer.scroll cget -activebackground]
    
    ::ansicolor::text .buffer.text -yscrollcommand { .buffer.scroll set } \
                                   -state disabled \
                                   -takefocus 0 \
                                   -background $ui(mud,bg) \
                                   -width 78 \
                                   -height 18

    # the mud will probably look better in a fixed-width font
    if {$mode == "gui"} {
        .buffer.text configure -font Courier
    }
    
    
    # define different colors depending on origin
    foreach type {mud irc sys tcl out} {
        if {$mode == "gui" && $type == "out"} {
            set ui(out,fg) $ui(out,fg,gui)
        }

        .buffer.text tag configure $type -wrap word \
                                         -foreground $ui($type,fg) \
                                         -background $ui($type,bg)
    
        if {$mode == "tui" && 
            ($type == "sys" || $type == "tcl" || $type == "out")} {
            .buffer.text tag configure $type -attributes bold
        }
    }
    
    pack .buffer.scroll -side right -fill y
    pack .buffer.text   -side left  -fill both -expand 1
    grid configure .buffer -column 0 \
                           -row 0 \
                           -columnspan $ui(colspan) \
                           -sticky news 


    #
    # Status Bar
    #
    
    set col -1
    foreach item [list time health status view] {
        set ITEM [string toupper $item]
        label .$item -textvariable ui($ITEM)
       
        switch $mode {
            tui { set ui($ITEM) [format %-$ui(status_width)s $ui($ITEM)]
                  .$item configure -foreground white \
                                   -takefocus 0 \
                                   -width $ui(status_width) }
            gui { .$item configure -font Courier }
        }
    
        grid configure .$item -row 1 -column [incr col] -sticky w -ipadx 1
    }
}
    
    
# Procs & Traces to keep status bar synched properly
proc status_bar_synchronize {name1 name2 op} {
    global ui

    switch -exact -- $name2 {
        realtime -  
        gametime { set data [list TIME "$ui(realtime) (~$ui(gametime))"] }
        hp       -
        sp       { set data [list HEALTH \
                       "[format %3s $ui(hp)] / [format %3s $ui(sp)]"] }
        status   { set data [list STATUS $ui(status)] }
        view     { set data [list VIEW   $ui(view)] }
        default  { error "Don't know what to do with \"$name2\"" }
    }

    foreach {var value} $data break
    set ui($var) [format %-$ui(status_width)s "${var}: $value"]
}

proc realtime {} {
    global ui
    
    set now  [clock seconds]
    set mmss [clock format $now -format "%Y-%m-%d %H:%M:00"]
    set next [clock scan "next minute" -base [clock scan $mmss]]
    set diff [expr {$next - $now}]

    set ui(realtime) [clock format $now -format "%H:%M"]
    after [expr {$diff * 1000}] realtime
    return $diff
}

proc gametime {} {
    global ui
 
    if {![string equal $ui(gametime) "--:--"]} {
        set ui(gametime) [clock format [clock scan "1 minute" \
            -base [clock scan $ui(gametime)]] -format "%H:%M"]

        # 10 sec in real time seems to be 1 minute in AA time
        set ui(gtime_synch_id) [after 10000 gametime]
    }
}


if {[trace vinfo ui(gametime)] == ""} {
    trace variable ui(gametime) w status_bar_synchronize 
    trace variable ui(realtime) w status_bar_synchronize
    trace variable ui(hp)       w status_bar_synchronize 
    trace variable ui(sp)       w status_bar_synchronize
    trace variable ui(status)   w status_bar_synchronize
    trace variable ui(view)     w status_bar_synchronize
}

# fire each trace once
realtime
foreach trace {gametime realtime hp sp status view} {
    set ui($trace) $ui($trace)
}


proc connection_status_synchronization {name1 name2 op} {
    global conn
    global ui

    set status "mud: [string equal $conn(mud) {}],\
                irc: [string equal $conn(irc) {}]"

    set status [string map {1 - 0 +} $status]

    switch -- $status {
        "mud: -, irc: -" { set ui(status) "Offline"  }
        "mud: -, irc: +" { set ui(status) "irc only" }
        "mud: +, irc: -" { set ui(status) "mud only" }
        "mud: +, irc: +" { set ui(status) "mud+irc"  }
        default          { error "Corrupted connection status: \"$status\"" }
    }

    # If we're no longer connected to the mud, lets null-ify hp & sp
    if {$name2 == "conn(mud)" && $conn(mud) == ""} {
        set ui(hp) ---
        set ui(sp) ---
    }
}


if {[trace vinfo conn(mud)] == ""} {
    trace variable conn(mud) w connection_status_synchronization
    trace variable conn(irc) w connection_status_synchronization
}


#
# Input Box
#

if {[info commands .input] == ""} {
    if {$mode == "gui"} {
        frame .input -borderwidth 1
    } else {
        if {$ui(tui_border_p)} {
            frame .input -border $ui(tui_box)
        } else {
            frame .input
        }
    }
    
    entry .input.entry -width 78 -textvariable ui(entry)
    pack .input.entry -fill x -expand 1
    grid configure .input -column 0 -row 2 -sticky ew -columnspan $ui(colspan)
    
    # Finish up the initial interface
    focus .input.entry
    update

    bind .input.entry <Prior> { .buffer.text yview scroll -1 pages }
    bind .input.entry <Next>  { 
        .buffer.text yview scroll  1 pages 
        if {[llength [.buffer.text bbox "end - 1 char"]]} {
            .buffer.scroll configure -background $::ui(orig_scroll_bg)
            .buffer.scroll configure -activebackground $::ui(orig_scroll_abg)
        }
    }
}


proc last_keystroke {name1 name2 op} {
    global ui
    set ui(last_keystroke) [clock seconds]
}

trace variable ui(entry) w last_keystroke


#
# Toggle between modes (GUI only)
#

proc view->toggle {desired} {
    global ui

    if {[string equal $desired $ui(view)]} {
        return
    }

    switch -- $desired {
        All { set elide? [list 0 0 0 0] }
        MUD { set elide? [list 0 1 1 1] }
        IRC { set elide? [list 1 0 1 1] }
        SYS { set elide? [list 1 1 0 1] }
        TCL { set elide? [list 1 1 1 0] }
        default { error "Do not know how to toggle to \"$desired\" view" }
    }

    foreach tag {mud irc sys tcl} elide_p ${elide?} {
        .buffer.text tag configure $tag -elide $elide_p
    }

    .buffer.text see "end - 1 char"
    set ui(view) $desired
}


# cwsh doesn't seem to support <Alt> and it doesn't have -elide on tags
if {$mode == "gui"} {
    bind . "<F1>" { view->toggle All }
    bind . "<F2>" { view->toggle MUD }
    bind . "<F3>" { view->toggle IRC }
    bind . "<F4>" { view->toggle SYS }
    bind . "<F5>" { view->toggle TCL }
}


###
#
# Handle user input
#
###

proc entry->process {{append 1}} {
    global ui

    set entry $ui(entry)

    if {[string equal [string trim $entry] ""]} {
        set ui(entry) ""
        / $entry
        return
    }

    set ui(entry) ""

    if {![string equal [lindex $ui(history) end] $entry] && $append} {
        if {$ui(echo)} {
            incr ui(pos)
            lappend ui(history) $entry
        }
    }


    set commands {}
    set entry [string map [list " ;" \x00] $entry]
    set running_pause 0

    foreach entry [split $entry \x00] {
        regexp {^(;+)([^;].*)?$} $entry => pause entry
   
        # pause 1/4 sec between command invocations
        if {[info exists pause]} {
            incr running_pause [expr {[string length $pause] * 250}]
            unset pause
        }
        
        if {[regexp {^(/\S+|@)\s*(.*)$} $entry => proc input]} {
            set proc [string map [list \\ \\\\ * \\* ? \\?] $proc]
    
            # does this command exist?
            if {[llength [info commands $proc]] == 1} {
                set proc  [string map [list \\ ""] $proc]
                set input [string trim $input]
    
                lappend commands [list $proc $input] $running_pause
            } else {
                # this command was not registered
                lappend commands bell $running_pause
                lappend commands \
                    [list buffer->append sys "No command for: $entry"] \
                    $running_pause
            }
        } else {
            # must be plain old standard input destined for the mud
            lappend commands [list / [string trim $entry]] $running_pause
        }
    }

    # schedule the commands
    foreach {command when} $commands {
        if {$when} {
            after $when $command
        } else {
            eval $command
        }
    }
}

# some bindings available in gui (wish) aren't available in tui (cwsh)
foreach keysm [list <Return> <KP_Enter> <Linefeed>] {
    catch { bind .input.entry $keysm entry->process } 
}


proc entry->history keysm {
    global ui

    switch -- $keysm {
        Up      -
        KP_Up   { set offset -1 }
        Down    -
        KP_Down { set offset 1 }
        default { error "Don't know how to handle <$keysm>" }
    }

    set size [llength $ui(history)]

    # Do we have any history?
    if {$size == 0} {
        return [bell]
    } 

    # We can't advance if we are at the end
    if {$offset == 1 && ($ui(pos) + 1 == $size)} {
        return [bell]
    }

    # special case
    if {$offset == -1 && $ui(pos) == 0 && 
        [string equal [string trim $ui(entry)] ""]} {
        set offset 0
    }

    # We can't go back if we are already at the beginning
    if {$offset == -1 && $ui(pos) == 0} { 
        return [bell]
    }

    # Was there pending input?
    if {![string equal [string trim $ui(entry)] ""]} {
        if {$ui(echo)} {
            if {$ui(pos) + 1 == $size} {
                # If we were at the bottom, add it to the history
                if {![string equal [lindex $ui(history) end] $ui(entry)]} {
                    lappend ui(history) $ui(entry)
                    incr ui(pos)
                }
            } else {
                # If we weren't at the bottom we update in place
                if {![string equal [lindex $ui(history) $ui(pos)] $ui(entry)]} {
                    set ui(history) \
                        [lreplace $ui(history) $ui(pos) $ui(pos) $ui(entry)]
                }
            }
        }
    } else {
        # No pending input? We won't bother going anywhere
        set offset 0
    }

    incr ui(pos) $offset
    set ui(entry) [lindex $ui(history) $ui(pos)]
}

# some bindings available in gui (wish) aren't available in tui (cwsh)
foreach keysm [list <Up> <Down> <KP_Up> <KP_Down>] {
    catch { 
        bind .input.entry $keysm {entry->history %K}
    }
}



###
#
# Output Buffer
#
###

proc buffer->append {kind input} {
    global ui
    global last_kind
    global no_new_line_p 

    if {$kind != "mud" && $kind != "irc" && $kind != "sys" && $kind != "tcl" &&
         $kind != "out"} {
        error "Do not know how to handle \"$kind\" input!"
    }

    if {![info exists last_kind]} {
        set last_kind {}
    }

    if {![info exists no_new_line_p]} {
        set no_new_line_p 0
    }

    if {[string length [string trim $input]] == 0} then return

    set end_visible_p [llength [.buffer.text bbox "end - 1 char"]]
    set input [string trimright $input]
    
    if {$ui(buf_counter) && (($kind == "mud" && !$no_new_line_p) || $kind != "mud")} {
        set input "\n$input"
    }

    set last_kind $kind

    .buffer.text configure -state normal -takefocus 1
    .buffer.text insert end $input $kind
    .buffer.text configure -state disabled -takefocus 0

    incr ui(buf_counter)

    if {$end_visible_p} {
        .buffer.text see "end - 1 char"
        .buffer.scroll configure -background $ui(orig_scroll_bg)
        .buffer.scroll configure -activebackground $ui(orig_scroll_abg)
    } else {
        .buffer.scroll configure -background $ui(alt_scroll_bg)
        .buffer.scroll configure -activebackground $ui(alt_scroll_abg)
    }
}



###
#
# Filters
#
###

if {![info exists filters]} {
    array set filters {mud {} irc {}}
}

proc filter->register {kind name flow_control regexp} {
    global filters

    set proc filter->${kind}->$name

    if {$kind != "mud" && $kind != "irc"} {
        error "Unknown kind of filter: \"$kind\" should be mud or irc"
    }

    if [catch { regexp -about $regexp } error] {
        error "Bad regular expression for $kind filter:\n$error"
    }

    switch -exact -- $flow_control {
        0 { set flow_control break }
        1 { set flow_control continue }
    }
       

    if {$flow_control != "continue" && $flow_control != "break"} {
        error "Bad flow control: \"$flow_control\", should be control or break"
    }

    set pos 0
    set updated_p 0

    foreach {__re __proc __flow_control} $filters($kind) {
        if {[string equal $proc $__proc]} {
            set filters($kind) [lreplace $filters($kind) \
                $pos [expr {$pos + 2}] $regexp $proc $flow_control]
            set updated_p 1
            break
        }
            
        incr pos 3
    }

    if {!$updated_p} {
        set filters($kind) [linsert $filters($kind) 0 \
            $regexp $proc $flow_control]
    }
}


proc filter->mud->hp/sp_prompt match {
    global ui

    foreach key {whole hp sp rest} val $match {
        set $key [string trim $val]
    }

    if {![string equal $hp $ui(hp)]} {
        set ui(hp) $hp
    }

    if {![string equal $sp $ui(sp)]} {
        set ui(sp) $sp
    }

    if {[string length $rest]} {
        buffer->append mud $rest
    }
}

proc filter->mud->hp/sp_combat match {
    global ui

    foreach {whole hp sp} $match break

    if {![string equal $hp $ui(hp)]} {
        set ui(hp) $hp
    } 

    if {![string equal $sp $ui(sp)]} {
        set ui(sp) $sp
    }
}


proc filter->mud->notice match {
    foreach {whole what_you_saw} $match break

    if {[regexp "you have already carved your name" $what_you_saw]} { 
        return
    }

    if {[regexp { (palm|plant) } $what_you_saw]} {
        buffer->append sys "*** ROUGE WARNING: $what_you_saw ***"
        bell
    }

    if {[regexp {^.+[.!?]\s*\S} $what_you_saw]} {
        return
    }

    outgoing->mud ":notices $what_you_saw"
}


proc filter->mud->gametime match {
    global ui

    foreach {whole time} $match break
    set ui(gametime) [clock format [clock scan $time] -format "%H:%M"]

    if {$ui(gtime_synch_id) != ""} {
        after cancel $ui(gtime_synch_id)
    }

    set ui(gtime_synch_id) [after 10000 gametime]
}

proc filter->mud->orc_patrol match {
    global ui
    
    if {[string is integer -strict $ui(hp)] && $ui(hp) <= 20} {
        outgoing->mud "quit"
        buffer->append sys "Emergency Self-Preservation Quit Taken\
            (HP too low to reliably escape Orc Patrol)"
    } elseif {($ui(last_keystroke) + 120) < [clock seconds]} {
        outgoing->mud "quit"
        buffer->append sys "Emergency Self-Preservation Quit Taken\
            (inactive > 120 seconds when Orc Patrol arrived)"
    } else {
        set stars [string repeat * 20]
        buffer->append sys "$stars WARNING ORC PATROL $stars"
    }

    for {set i 1} {$i <= 3} {incr i} {
        bell
    }
}

proc filter->mud->login match {
    outgoing->mud "time"    
#    outgoing->mud "ansi off"
#    outgoing->mud "eline *"
}

proc filter->mud->fumar match {
    global tcl_platform

    if {$tcl_platform(user) == "michael"} {
        outgoing->mud "refill pipe"
        outgoing->mud "smoke pipe"
    } else {
        buffer->append sys \
            "[string repeat = 20]> Your Pipe Went Out <[string repeat = 20]"
    }
}


proc filter->mud->anti-rouge match {
    foreach {whole who what} $match break
    buffer->append sys "*** ROUGE WARNING: $whole ***"
    bell
    outgoing->mud ":just caught $who $what!"
    outgoing->mud "tell $who Give me cash or be bountied..."
}

proc filter->mud->echo-off match {
    global ui
    set ui(echo) 0
}

proc filter->mud->echo-on match {
    global ui
    set ui(echo) 1
}

proc filter->mud->gclaim match {
    after 4000 [list buffer->append sys "You can now gclaim again"]
}

proc filter->mud->fast-relogin match {
    after 1000 /mud connect
}

filter->register mud hp/sp_prompt $::ui(show_prompt_p) \
    {^\s*(\d+)\s*:\s*(\d+)\s*>\s*(.+)$}

filter->register mud hp/sp_combat continue {^HP:\s+(\d+)\s+SP:\s+(\d+)\s*$}
filter->register mud gametime continue {^Game time is:\s+(\d\d?:\d\d [ap]m)\s*$}
filter->register mud orc_patrol continue {(?i)^An Orc Patrol Leader}
filter->register mud login continue {(?i)^Your last login was \d}
filter->register mud fumar continue {(?i)^The pipe is empty and goes out}
filter->register mud notice continue {(?i)^You notice (.+)$}
filter->register mud anti-rouge continue {(?i)^You glance back and catch (\S+) (attempting to \S+) }
filter->register mud echo-off continue [format %c%c%c 255 251 1]
filter->register mud echo-on  continue [format %c%c%c 255 252 1]
filter->register mud gclaim continue {You pile up some stones to form a cairn}
#filter->register mud fast-relogin continue {^Closing down.\s*$}



###
#
# I/O to mud & irc
#
###


proc incoming->mud {} {
    global conn
    global filters
    global debug_p
    global no_new_line_p

    if {$conn(mud) == ""} {
        return -1
    }

    if {$debug_p >= 3} {
        buffer->append sys "[clock format [clock seconds] -format "%H:%M:%S"]:\
            conn $conn(mud), eof: [eof $conn(mud)]"
    }

    if {[eof $conn(mud)]} {
        buffer->append sys "End of file detected on connection to mud.\
            (Received $conn(mud_bytes) bytes)"
        update idletasks

        catch { close $conn(mud) }
        set conn(mud) ""

#        if {$conn(mud_bytes) == 0} {
#            after 1000 /mud connect
#        }

        return -1
    }

    if {$conn(mud_bytes) == 0} {
        if {[catch { set line [gets $conn(mud)] }]} then return
        if {[string length $line] == 0} then return
    } else {
        set line [gets $conn(mud)]
        set line [string map -nocase [list \x66\x75\x63\x6b f***] $line]
    }

    if {$conn(mud_bytes) == 0} {
        buffer->append sys "Connection established ($conn(mud))"
    }
    incr conn(mud_bytes) [string length $line]

    if {[fblocked $conn(mud)]} {
        while {[string length [set c [read $conn(mud) 1]]] && $c != "\n"} {
            append line $c
        }

        if {$c != "\n"} {
            set no_new_line_p 1
        } else {
           set no_new_line_p 0
        }
    } else {
        append line \n
        set no_new_line_p 0
    }

    if {[string length $line]} {
        return [incoming mud $line]
    } else {
        return -1
    }
}


proc incoming {from line} {
    global filters
 
    if {![info exists filters($from)]} {
        return -1
    }

    foreach {regexp command flow_control} $filters($from) {
 
        if {$::debug_p >= 4} {
            buffer->append sys "Filter Reg Exp: $regexp"
            buffer->append sys "Filter Command: $command"
            buffer->append sys "Filter FlowControl: $flow_control"
        }

        regsub -all -- {\x1b\[[^m]+m} $line "" ansi_free_line 

        if {[regexp -- $regexp $ansi_free_line]} {
            if {$::debug_p >= 4} {
                buffer->append sys "Filter Succeeded"
                buffer->append sys "Invoking:\
                    $command [regexp -inline -all -- $regexp $ansi_free_line]"
            }

            $command [regexp -inline -all -- $regexp $ansi_free_line]
            switch -- $flow_control {
                break    { break }
                continue { continue }
                default  { error "Unknown flow control: \"$flow_control\"" }
            }
        } else {
            if {$::debug_p >= 4} {
                buffer->append sys "Filter Failed on \"$ansi_free_line\""
            }

            unset regexp
            unset command
            unset flow_control
        }
    }

    # see if we need to take default action
    if {![info exists flow_control] || $flow_control == "continue"} {
        buffer->append $from $line
    }
 
    return [string length $line]
}


proc outgoing->mud what {
    global conn
    global ui
    global debug_p

    if {$conn(mud) == "" || [eof $conn(mud)]} {
        bell
        return
    }

    if {$debug_p >= 2} {
        buffer->append sys [list puts $conn(mud) $what]
    }

    puts $conn(mud) $what
    if {$ui(echo)} {
        buffer->append out $what
    }
}


proc connected->mud {} {
    global conn
    global ui
 
    fileevent $conn(mud) writable {}

    if {$conn(irc) != ""} {
        set ui(status) "mud+irc"
    } else {
        set ui(status) "mud only"
    }

    buffer->append sys "Connected to the mud."
}


proc irc->ping pong {
    global conn

    if {$::debug_p >= 2} {
        buffer->append sys "PONG: $pong"
    }

    $conn(irc) send "PONG [string trim $pong :]"
    set conn(irc,last_ping) [clock seconds]
}


proc irc->EOF args {
    global conn

    bell 
    buffer->append sys "IRC connection closed by remote server"

    set conn(irc) ""
    set conn(channels) ""
}


proc incoming->irc {what who {rest ""}} {
    global conn

    set who [string trimleft $who :]
    set channel [lindex $conn(channels) end]

    if {[string length $rest] == 0} {
        set rest $who
        set who ""
    }

    if {[string equal PRIVMSG $what] &&
        [regexp {^(\S+) :(.*)$} $rest => dest text]} {
        foreach who [split $who !] break

        set public_p [string match "#*" $dest]
        set curr_p   [string equal $dest $channel]
        set emote_p  [regexp "(?:\x01|\\x01)ACTION (.*)(?:\x01|\\x01)" \
            $text => text]

        switch [join [list $public_p $emote_p $curr_p] ,] {
            1,1,1 { set prefix "* $who" }
            1,1,0 { set prefix "* ${who}:$dest" }
            1,0,1 { set prefix "<$who>" }
            1,0,0 { set prefix "<${who}:$dest>" }
            0,1,1 { set prefix "\[* $who\]" }
            0,1,0 { set prefix "\[* $who\]" }
            0,0,1 { set prefix "\[$who\]" }
            0,0,0 { set prefix "\[$who\]" }
            default { error "Impossible condition" }
        }

        set irc_output "$prefix $text"
    } else {
        set irc_output [list $what $who $rest]
    }

    lappend ::conn(irc_history) $irc_output
    buffer->append irc $irc_output
}



###
#
# /commands ...
#
###

proc /irchistory input {
    global conn

    if {![info exists conn(irc_history)]} {
        bell
        buffer->append sys "No irc history to display"
        return
    }

    set input [string trim $input]
    if {![string is integer -strict $input] || $input < 1} {
        set input 8
    }

    set length [llength $conn(irc_history)]
    if {$input >= $length} {
        set start 0
    } else {
        set start [expr {$length - $input}]
    }
 
    buffer->append sys "<irchistory>"

    foreach entry [lrange $conn(irc_history) $start end] {
        buffer->append irc "$entry"
    }
    buffer->append sys "</irchistory>"
}

interp alias {} /irchist {} /irchistory


proc /mud input {
    global conn
    global ui

    if {[regexp {^connect(?:\s+(\S+)(?:\s+(\d+)?)?)?$} $input => host port]} {
        if {[string equal $host ""]} {
            set host ancient.anguish.org
        }

        if {[string equal $port ""]} {
            set port 2222
        }

        if {$conn(mud) != ""} {
            buffer->append sys \
                "You are already connected to a mud! Disconnect first"
        } else {
            buffer->append sys "Attempting to connect to $host (port $port)..."
            set conn(mud) [socket -async $host $port]
            fconfigure $conn(mud) -buffering none -blocking 0 

            set conn(mud_bytes) 0
            fileevent $conn(mud) readable incoming->mud
            vwait conn(mud_bytes)
            fileevent $conn(mud) writable connected->mud

            vwait ui(status)
        }
    } elseif {[string equal disconnect $input]} {
        if {$conn(mud) != ""} {
            catch { flush $conn(mud) }
            catch { close $conn(mud) }
            set conn(mud) ""
            
            buffer->append sys "Connection to mud closed."
        } else {
            buffer->append sys "No open mud connection to close."
        }
    } elseif {[string length $input] == 0} {
        if {$conn(mud) == ""} {
            buffer->append sys "You are not currently connected to the mud."
        } else {
            buffer->append sys "You are connected to the mud."
        }
    } else {
        bell
        buffer->append sys "Huh? What does: \"/mud $input\" mean?"
    }
}


proc /irc input {
    global conn

    set input [string trim $input]
    if {[regexp {^connect(?:\s+(\S+)(?:\s+(\d+)?)?)?$} $input => host port]} {
        if {$conn(irc) != ""} {
            bell
            buffer->append sys "Already connected to an IRC server(!)"
            return
        }

        if {[string equal $host ""]} { set host 204.228.146.16 }
        if {[string equal $port ""]} { set port 6667 }

        package require irc
        set conn(irc) [::irc::connection $host $port]

        buffer->append sys \
            "Attempting to connect to irc server $host on port $port"

        $conn(irc) connect
        $conn(irc) user $::tcl_platform(user) [info hostname] \
            "mudfest mud+irc Tcl client ($::mode mode)"

        $conn(irc) registerevent PING irc->ping
        $conn(irc) registerevent EOF  irc->EOF
        $conn(irc) registerevent defaultevent incoming->irc
        $conn(irc) registerevent defaultcmd   incoming->irc

        buffer->append sys "Connected on IRC.  Use /nick then /join now."
    } elseif {[string equal "disconnect" $input]} {
        if {$conn(irc) == ""} {
            bell
            buffer->append sys \
                "You can't disconnect to irc because you aren't connected!"
            return
        }

        foreach channel $conn(channels) {
            $conn(irc) part $channel
        }

        set proc $conn(irc)
        if {[regexp {^(irc::irc\d+::[^:]+::)network$} $proc => namespace]} {
            if {[info exists ${namespace}::sock]} {
                catch { close [set ${namespace}::sock] }
            }
        }

        set conn(irc) ""
        set conn(channels) ""
        set conn(nick) ""

        buffer->append sys "Connection to irc server closed."
    } else {
        bell
        buffer->append sys "Didn't understand /irc as given."
    }
}

proc /nick input {
    global conn

    if {$conn(irc) == ""} {
        bell
        buffer->append sys "Cannot set /nick; not connected to IRC yet."
        return
    }

    if {![string is word -strict $input]} {
        bell 
        buffer->append sys "Invalid irc nickname: \"$input\""
        return
    }

    $conn(irc) nick $input
    set conn(nick) $input
}

proc /join input {
    global conn
 
    if {$conn(irc) == ""} {
        bell
        buffer->append sys "Cannot join a channel; not connected to IRC yet."
        return
    }

    set input [string tolower $input]
    if {![string is word -strict [string range $input 1 end]] ||
        ![string equal "#" [string range $input 0 0]]} {
        bell
        buffer->append sys "Invalid channel: \"$input\""
        return
    }

    set pos [lsearch -exact $conn(channels) $input]
    if {$pos == -1} {
        $conn(irc) join $input
    } else {
        set conn(channels) [lreplace $conn(channels) $pos $pos]
        buffer->append sys "Default channel is now $input"
    }

    lappend ::conn(channels) $input
}

proc /msg input {
    global conn

    if {$conn(irc) == ""} {
        bell
        buffer->append sys "You are not connected to an irc server."
        return
    }

    if {![regexp {^\s*(\S+)\s+(.+)$} $input => destination message]} {
        bell
        return
    } 

    set destination [string tolower $destination]

    if {[string range $destination 0 0] == "#"} {
        if {[lsearch $conn(channels) $destination] == -1} { 
            bell
            buffer->append sys "You are not on channel $destination"
            return
        } 

        if {[lindex $conn(channels) end] == $destination} {
            buffer->append irc "<$conn(nick)> $message"
        } else {
            buffer->append irc "<$conn(nick):$destination> $message"
        }
    } else {
        buffer->append irc "<->$destination> $message"
    }

    $conn(irc) privmsg $destination $message
}

proc /say input {
    global conn
    
    if {$conn(irc) == ""} {
        bell
        buffer->append sys "You are not connected to an irc server."
        return
    }

    if {$conn(channels) == ""} {
        bell
        buffer->append sys "You are not currently on an irc channel."
        return
    }

    $conn(irc) privmsg [lindex $conn(channels) end] $input
    lappend ::conn(irc_history) "<$conn(nick)> $input"
    buffer->append irc "<$conn(nick)> $input"
}

interp alias {} @ {} /say

proc /me input {
    global conn
  
    if {$conn(irc) == ""} {
        bell
        buffer->append sys "You are not connected to an irc server."
        return
    }

    if {$conn(channels) == ""} {
        bell
        buffer->append sys "You are not on an irc channel."
        return
    }

    set emote \x01
    append emote "ACTION "
    append emote $input
    append emote \x01

    $conn(irc) privmsg [lindex $conn(channels) end] $emote
    lappend ::conn(irc_history) "* $conn(nick) $input"
    buffer->append irc "* $conn(nick) $input"
}


proc /quit input {
    catch { / quit }
    catch { /mud disconnect }
    catch { /part #mud }

    after 200 exit
    update idletasks
    update
}

proc /abort input {
    exit
}

proc / input {
    global conn
    global ui

    if {$conn(mud) != ""} {
        outgoing->mud $input
    } else {
        buffer->append sys $input
    }
}

proc /eval input {
    if {[info complete $input]} {
        buffer->append tcl "% $input"
        catch { eval $input } result
        buffer->append tcl $result
    } else {
        bell
        buffer->append sys "Unable to evaluate -- command not complete: $input"
    }
}

# make /tcl a synonym of /eval
interp alias {} /tcl {} /eval


proc /reload input {
    if {[string length $input]} {
        bell
        buffer->append sys "Reload doesn't know how to take any arguments yet"
    } else {
        buffer->append sys "Attempting to reload $::script ..."
        uplevel #0 source $::script
        buffer->append sys "... $::script reloaded!"
    }
}

proc /go input {
    if {[string equal $input ""]} {
        return
    }

    foreach move [split $input ,] {
        set move [string trim $move]
        if {[regexp {^(\d+)(\D+)$} $move => ntimes action]} {
            for {set i 1} {$i <= $ntimes} {incr i} {
                outgoing->mud [string trim $action]
            }
        } else {
            outgoing->mud [string trim $move]
        }
    }
}


proc /back input {
    global /
    if {[info exists /(back)]} {
        /from [set /(back)]
    }
}

proc /sback input {
    global /
    if {[info exists /(back)]} {
        /scut [set /(back)]
    }
}


proc /directions input {
    if {![regexp {^\s*(\S+),?\s+(\S+)\s*$} $input => origin dest]} {
        bell
        buffer->append sys "Huh? Where did you want to go?"
        return
    }

    set go [AA-routes $origin $dest]
    if {$go != ""} {
        buffer->append sys "[string toupper "$origin -> $dest:"] $go"
        return
    }

    set to_xr   [AA-routes $origin xroads]
    set from_xr [AA-routes xroads $dest]

    if {$to_xr != "" && $from_xr != ""} {
        buffer->append sys "[string toupper "$origin -> XROADS:"] $to_xr"
        buffer->append sys "[string toupper "XROADS -> $dest:"] $from_xr"
        return
    }

    bell
    buffer->append sys \
        "Can't figure out how to get from \"$origin\" to \"$dest\" ..."
}
    


proc /from input {
    global /

    if {![regexp {^\s*(\S+),?\s+(\S+)\s*$} $input => origin dest]} {
        bell
        buffer->append sys "Huh? Where did you want to go?"
        return
    }

    set go [AA-routes $origin $dest]
    if {$go != ""} {
        set /(back) "$dest $origin"
        return [/go $go]
    }

    set to_xr   [AA-routes $origin xroads]
    set from_xr [AA-routes xroads $dest]

    if {$to_xr != "" && $from_xr != ""} {
        /go $to_xr
        /go $from_xr
        set /(back) "$dest $origin"
        return
    }

    bell
    buffer->append sys \
        "Can't figure out how to get from \"$origin\" to \"$dest\" ..."
}

proc /decorpse input {
    set input [string trim $input]
    if {![string is integer -strict $input]} {
        set input 1
    }
 
    foreach verb [list scalp skin pluck carve gut] {
        outgoing->mud "$verb corpse $input"
    }

    outgoing->mud "open pack"

    foreach thing [list "all pelt" sinew feathers meat scalp] {
        outgoing->mud "put $thing in pack"
    }

#    outgoing->mud "close pack"
}

interp alias {} /dc     {} /decorpse
interp alias {} /decorp {} /decorpse

proc /pipe input {
    if {[string equal $input ""]} {
        set input "parkraz"
    }

    knights-pack-pre
    outgoing->mud "get $input from pack"
    outgoing->mud "get pipe from pack"
    outgoing->mud "refill pipe"
    outgoing->mud "light pipe"
    outgoing->mud "put $input in pack"
    knights-pack-post
}

proc /ears input {
    knights-pack-pre
    outgoing->mud "get bag from pack"
    outgoing->mud "put all ears in bag"
    outgoing->mud "examine bag"
    outgoing->mud "put bag in pack"
    knights-pack-post
}

interp alias {} /ear {} /ears

proc /et input {
    if {![string is integer -strict $input] || $input <= 0} {
        set input 1
    }

    outgoing->mud "trophy corpse $input"
    /ears $input
}

proc /brawl input {
    if {[string equal $input ""]} {
        set input "sword"
    }
	outgoing->mud "remove shield"
	outgoing->mud "unwield $input"
	outgoing->mud "brawl"
}

proc /unbrawl { {weapon "sword"} {num "1"}} {
	outgoing->mud "brawl"
	outgoing->mud "wield $weapon $num"
	outgoing->mud "wear shield"
}

proc /lpack input {
    outgoing->mud "open pack"
    outgoing->mud "examine pack"
#    outgoing->mud "close pack"
}

# Make an alias
interp alias {} /ipack {} /lpack

proc /gpack input {
    if {[string equal [string trim $input] ""]} {
        knights-pack-post
    } else {
        outgoing->mud "open pack"
        outgoing->mud "get $input from pack"
#        outgoing->mud "close pack"
    }
}

proc /gpack! input {
    knights-pack-pre
    outgoing->mud "get $input from pack"
    knights-pack-post
}

proc /ppack input {
    outgoing->mud "open pack"
    outgoing->mud "put $input in pack" 
#    outgoing->mud "close pack"
}

proc /dump input {
    set input [string trim $input]
    if {[string length $input] == 0} {
        set input [file join [pwd] mudfest.log]
    }

    catch { 
        set fp [open $input w]
        puts $fp [.buffer.text get 1.0 end]
        close $fp
    } message

    if {$message == ""} {
        buffer->append sys "Saved buffer to $input"
    } else {
        bell
        buffer->append sys "Error occured while saving buffer: $message"
    }
}


proc /feed input {
}

proc /version input {
    global RCSID
    buffer->append sys "Version Info: $RCSID"
}

proc knights-pack-pre {} {
    outgoing->mud "open pack"
    outgoing->mud "unkeep pack"
    outgoing->mud "drop pack"
}

proc /rpack input {
    knights-pack-pre
}

proc /dpack input {
    knights-pack-pre
}

proc /wpack input {
    knights-pack-post
}

proc knights-pack-post {} {
    outgoing->mud "get pack"
    outgoing->mud "wear pack"
    outgoing->mud "keep pack"
#    outgoing->mud "close pack"
}


proc AA-routes {origin dest} {
    set origin [string tolower $origin]
    set dest   [string tolower $dest]

    if {[string equal $origin xr]} {
        set origin xroads
    }

    if {[string equal $dest xr]} {
        set dest xroads
    }


    # Good source of directions: http://www.lividity.org/omniscent/dirs.html

    # Significantly expanded routes courtesy of Telcontar (aka ...)
    switch -exact -- $origin,$dest {

        nep,xroads          -
        nepeth,xroads       { set go "3s, e, 6s, e, s, 11e" }
        xroads,nepeth       -
	xroads,nep          { set go "11w, n, w, 6n, w, 3n" }

        nepflower,xroads          -
        nepethflowershop,xroads   { set go "n, 2e, 3s, e, 6s, e, s, 11e" }
        xroads,nepethflowershop   -
        xroads,nepflower          { set go "11w, n, w, 6n, w, 3n, 2w, s" }

        nepbar,xroads          		-
        nepinnbar,xroads          	-
        nepancientblissinnbar,xroads    -
        nepethinnbar,xroads       	{ set go "s, e, s, 2e, 3s, e, 6s, e, s, 11e" }
        xroads,nepbar       		-
	xroads,nepinnbar       		-
	xroads,nepancientblissinnbar    -
        xroads,nepethinnbar          	{ set go "11w, n, w, 6n, w, 3n, 2w, n, w, n" }

        nepbard,xroads          	-
        nepinnbard,xroads          	-
        nepancientblissinnbard,xroads   -
        nepethinnbard,xroads       	{ set go "w, s, 2e, 3s, e, 6s, e, s, 11e" }
        xroads,nepbard       		-
        xroads,nepinnbard      		-
        xroads,nepancientblissinnbard   -
        xroads,nepethinnbard       	{ set go "11w, n, w, 6n, w, 3n, 2w, n, e" }

        nepbutcher,xroads          -
        nepethbutcher,xroads       { set go "w, s, 2w, 3s, e, 6s, e, s, 11e" }
        xroads,nepethbutcher       -
        xroads,nepbutcher          { set go "11w, n, w, 6n, w, 3n, 2e, n, e" }

	neplaw,xroads		-
        nepsheriff,xroads       -
        nepethsheriff,xroads	{ set go "open w, 3w, 3s, e, 6s, e, s, 11e" }
        xroads,nepethsheriff   	-
	xroads,neplaw		-
        xroads,nepsheriff	{ set go "11w, n, w, 6n, w, 3n, 2e, open e, e" }

	nep,nepshop	    -
        nepeth,nepshop      { set go "4n, 2w, n" }
	nepshop,nep	    -
        nepshop,nepeth      { set go "s, 2e, 4s" }

	nepethshop,xroads   -
        nepshop,xroads      { set go "s, 2e, 7s, e, 6s, e, s, 11e" }
	xroads,nepethshop   -
        xroads,nepshop      { set go "11w, n, w, 6n, w, 7n, 2w, n" }

	knights,xroads	    -
        knightsguild,xroads -
        kg,xroads           { set go "2s, open oak door, 8s, e, 6s, e, s, 11e" }
	xroads,knights	    -
        xroads,knightsguild -
        xroads,kg           { set go "11w, n, w, 6n, w, 7n, open oak door, 3n" }

        knightsden,xroads   -
        kden,xroads         { set go "w, 2s, open south, 8s, e, 6s, e, s, 11e" }
        xroads,knightsden   -
        xroads,kden         { set go "11w, n, w, 6n, w, 7n, open north, 3n, e" }

        knightshop,xroads   -
        kshop,xroads        { set go "e, 3s, open oak door, 8s, e, 6s, e, s, 11e" }
        xroads,knightshop   -
        xroads,kshop        { set go "11w, n, w, 6n, w, 7n, open oak door, 4n, w" }

        misha,xroads        { set go "2s, w, open west, w, open south, 8s, e, 6s, e, s, 11e" }
        xroads,misha        { set go "11w, n, w, 6n, w, 7n, open north, n, open east, 2e, 2n" }

	earclerk,xroads      -
        albert,xroads        { set go "e, 2s, open oak door, 8s, e, 6s, e, s, 11e" }
	xroads,earclerk	     -
        xroads,albert        { set go "11w, n, w, 6n, w, 7n, open oak door, 3n, w" }



        phall,xroads        { set go "out, mount horse, 2w, 3s, 5w, 6s, e, s, 11e" }
        xroads,phall        { set go "11w, n, w, 6n, 5e, 3n, 2e, dismount horse, enter" }

        phall,neville       { set go "out, 3s, e, n" }
        neville,phall       { set go "s, w, 3n, enter hall" }

        samantha,xroads     { set go "e, out, 2w, 3s, 5w, 6s, e, s, 11e" }
        xroads,samantha     { set go "11w, n, w, 6n, 5e, 3n, 2e, enter, w" }

        samantha,picckard   { set go "e, out, 3s, e, 2n, 2e, s" }
        picckard,samantha   { set go "n, 2w, 2s, w, 3n, enter hall, w" }

        pestates,xroads     { set go "sw, 4n, 5e, 5n, 11e" }
        xroads,pestates     { set go "11w, 5s, 5w, 4s, ne" }


        balan,xroads        { set go "2e, 2s, e, s, 11e" }
        xroads,balan        { set go "11w, n, w, 2n, 2w" }

        xroads,andeli { set go "11w, n, w, 6n, 5e, 18n, 10w, 3u" }
        andeli,xroads { set go "3d, 10e, 18s, 5w, 6s, e, s, 11e" }

        xroads,greenhaven { set go "11w, n, w, 6n, 5e, 17n, 12w, 5nw, 4w" }
        greenhaven,xroads { set go "4e, 5se, 12e, 17s, 5w, 6s, e, s, 11e" }

        xroads,zhamarr { set go "11w, n, w, 6n, 5e, 18n, w, 2n, 17w" }
        zhamarr,xroads { set go "17e, 2s, e, 18s, 5w, 6s, e, s, 11e" }

        xroads,gnolltemple -
        xroads,gnoll       { set go "11w, n, w, 6n, 5e, 18n, 9w, 10n, 6e, ne" }
        gnoll,xroads       -
        gnolltemple,xroads { set go "sw, 6w, 10s, 9e, 18s, 5w, 6s, e, s, 11e" }

        hob,xroads          -
        hobbitat,xroads     { set go "19s, 5w, 6s, e, s, 11e" }
        xroads,hob          -
        xroads,hobbitat     { set go "11w, n, w, 6n, 5e, 19n" }

        hobbarbershop,xroads    - 
	hobhair			-
        hobbarber,xroads     	{ set go "3w, 2n, e, 2s, w, 18s, 5w, 6s, e, s, 11e" }
        xroads,hobbarbershop    -
	xroads,hobhair		-
        xroads,hobbarber     	{ set go "11w, n, w, 6n, 5e, 18n, e, 2n, w, 2s, 3e" }

        hobbank,xroads    	-
        hobbitatbank,xroads  	{ set go "2e, 2n, e, 2s, w, 18s, 5w, 6s, e, s, 11e" }
        xroads,hobbank   	-
        xroads,hobbitatbank 	{ set go "11w, n, w, 6n, 5e, 18n, e, 2n, w, 2s, 2w" }

        hobshop,xroads          - 
        hobbitatshop,xroads     { set go "w, sw, 20s, 5w, 6s, e, s, 11e" }
        xroads,hobshop          -
        xroads,hobbitatshop     { set go "11w, n, w, 6n, 5e, 20n, ne, e" }

        hobstore,xroads          -
        hobbitatstore,xroads     { set go "w, nw, 2w, s, sw, 20s, 5w, 6s, e, s, 11e" }
        xroads,hobstore          -
        xroads,hobbitatstore     { set go "11w, n, w, 6n, 5e, 20n, ne, n, 2e, se, e" }



        growle,xroads		-
	bearguild,xroads	-
        blackbear,xroads	{ set go "2n, 2e, 2s, 9e, 18s, 5w, 6s, e, s, 11e" }
        xroads,growle		-
        xroads,bearguild	-
        xroads,blackbear	{ set go "11w, n, w, 6n, 5e, 18n, 9w, 2n, 2w, 2s" }

        sequin,xroads           -
        bearchutes,xroads       -
        bchutes,xroads        	{ set go "w, 3n, 2e, 2s, 9e, 18s, 5w, 6s, e, s, 11e" }
        xroads,sequin           -
        xroads,bearchutes       -
        xroads,bchutes          { set go "11w, n, w, 6n, 5e, 18n, 9w, 2n, 2w, 3s, e" }


        musicman,xroads         -
        questmusicman,xroads    { set go "d, s, w, 7s, 9e, 18s, 5w, 6s, e, s, 11e" }
        xroads,musicman         -
        xroads,questmusicman    { set go "11w, n, w, 6n, 5e, 18n, 9w, 7n, e, n, u" }


        hobbitat,thranarack     -
        hobbitat,dwarvenvillage -
        hobbitat,dwarfvillage   -
        hob,thranarack          -
        hob,dwarvenvillage      -
        hob,dwarfvillage        { set go "s, 9w, 2n, 4w, 3n" }
        thranarack,hobbitat     -
        dwarvenvillage,hobbitat -
        dwarfvillage,hobbitat   -
        thranarack,hob          -
        dwarvenvillage,hob      -
        dwarfvillage,hob        { set go "3s, 4e, 2s, 9e, n" }

        dwarvenvillage,bearguild -
        dwarfvillage,bearguild   -
        thranarack,bearguild     -
        dwarvenvillage,blackbear -
        dwarfvillage,blackbear   -
        dwarvenvillage,growle    -
        dwarfvillage,growle      -
        thranarack,growle        { set go "3s, 2e, 2s" }
        bearguild,dwarvenvillage -
        bearguild,dwarfvillage   -
        bearguild,thranarack     -
        blackbear,dwarvenvillage -
        blackbear,dwarfvillage   -
        blackbear,thranarack     -
        growle,dwarvenvillage    -
        growle,dwarfvillage      -
        growle,thranarack        { set go "2n, 2w, 3n" }

        zhou,xroads         -
        zhao,xroads         { set go "w, 13s, 5w, 6s, e, s, 11e" }
        xroads,zhao         -
        xroads,zhou         { set go "11w, n, w, 6n, 5e, 13n, e" }



	nev,xroads	    -
        neville,xroads      { set go "s, 8w, 6s, e, s, 11e" }
	xroads,nev  	    -
        xroads,neville      { set go "11w, n, w, 6n, 8e, n" }

        neville,picckard    { set go "n, 2e, s" }
        picckard,neville    { set go "n, 2w, s" }

	nevinn,xroads		-
	nevilleancientinn,xroads  -	
        nevilleinn,xroads	{ set go "n, w, 2s, 8w, 6s, e, s, 11e" }
	xroads,nevinn		-
	xroads,nevilleancientinn  -
        xroads,neville 		{ set go "11w, n, w, 6n, 8e, 2n, e, s" }

	nevlaw,xroads		-
	picckard,xroads		-
	nevconst,xroads		-
	nevjail,xroads		-
        nevillejail,xroads      { set go "n, 2w, 2s, 8w, 6s, e, s, 11e" }
	xroads,nevlaw		-
	xroads,picckard		-
	xroads,nevconst		-
	xroads,nevjail		-
        xroads,neville      	{ set go "11w, n, w, 6n, 8e, 2n, 2e, s" }

	oterim,xroads		-
	nevsage,xroads		-
        nevillesage,xroads      { set go "s, 2w, 2s, 8w, 6s, e, s, 11e" }
	xroads,oterim		-
	xroads,nevsage		-
        xroads,nevillesage      { set go "11w, n, w, 6n, 8e, 2n, 2e, n" }



        cx,xroads           { set go "e, n, 2w" }
        xroads,cx           { set go "2e, s, w" }

        cp,xroads           { set go "u, e, n, 2w" }
        xroads,cp           { set go "2e, s, w, d" }

	arena,xroads		-
	brawlarena,xroads	{ set go "s, w, s" }
	xroads,arena		-
	xroads,brawlarena	{ set go "n, e, n" }

	academy,xroads		-
	trainingacademy,xroads	-
        brawltrain,xroads       { set go "w, s" }
	xroads,academy		-
	xroads,trainingacademy	-
        xroads,brawltrain       { set go "n, e" }

	fhall,xroads		-
	fightershall,xroads	-
	fighters,xroads		-
        fightersguild,xroads    { set go "e, 2s" }
	xroads,fhall		-
	xroads,fightershall	-
	xroads,fighters		-
        xroads,fightersguild    { set go "2n, w" }

        raven,xroads        -
        bakery,xroads       { set go "n, 2w, 5s" }
        xroads,raven        -
        xroads,bakery       { set go "5n, 2e, s" }

	ngate,xroads		-
	northgate,xroads	{ set go "6s" }
	xroads,ngate		-
	xroads,northgate	{ set go "6n" }

	decker,xroads	    -
        shop,xroads         { set go "s, e" }
	xroads,decker	    -
        xroads,shop         { set go "w, n" }

        adventurersguild,xroads	-
	advguild,xroads		{ set go "n, e" }
	xroads,adventurersguild	-
        xroads,advguild         { set go "w, s" }

        paperboy,xroads     { set go "3e" }
        xroads,paperboy     { set go "3w" }

        bank,xroads         { set go "w, n, 3e" }
        xroads,bank         { set go "3w, s, e" }

        postoffice,xroads   { set go "2n, 3e" }
        xroads,postoffice   { set go "3w, 2s" }

	mages,xroads		-
	magetw,xroads		-
        magetower,xroads        { set go "d, e, n, 3e" }
	xroads,mages		-
	xroads,magetw		-
        xroads,magetower 	{ set go "3w, s, w, u" }

	clericsguild,xroads -
	clerics,xroads	    -
        church,xroads       { set go "w, s, w, s, 3e" }
	xroads,clericsguild -
	xroads,clerics	    -
        xroads,church       { set go "3w, n, e, n, e" }

        tantpub,xroads     { set go "2s, 3e" }
        xroads,tantpub     { set go "3w, 2n" }

	tantlib,xroads		-
        tantlibrary,xroads	{ set go "e, s, 3e" }
	xroads,tantlib		-
        xroads,tantlibrary	{ set go "3w, n, w" }

        ancientinn,xroads   -
        start,xroads        { set go "s, 6e" }
        xroads,ancientinn   -
        xroads,start        { set go "6w, n" }

        willim,xroads	-
        smithy,xroads	{ set go "n, 6e" }
        xroads,willim	-
        xroads,smithy	{ set go "6w, s" }

	wgate,xroads		-
	westgate,xroads		{ set go "7e" }
	xroads,wgate		-
	xroads,westgate		{ set go "7w" }

        canticle,xroads     { set go "out, 8e" }
        xroads,canticle     { set go "8w, enter hut" }

        humpback,xroads     { set go "8e" }
        xroads,humpback     { set go "8w" }

        coachline,xroads    { set go "e, 2n, 5e" }
        xroads,coachline    { set go "5w, 2s, w" }

	tantmagic,xroads    -
        magicshop,xroads    { set go "w, 2n, 5e" }
	xroads,tantmagic    - 
        xroads,magicshop    { set go "5w, 2s, e" }

	hanza,xroads	  -
        mapshop,xroads    { set go "e, 3n, 5e" }
	xroads,hanza	  -
        xroads,mapshop    { set go "5w, 3s, w" }

        equipshop,xroads    { set go "4n, 5e" }
        xroads,equipshop    { set go "5w, 4s" }

        auction,xroads      { set go "n, w, 3n, 5e" }
        xroads,auction      { set go "5w, 3s, e, s" }

        weapshop,xroads      { set go "n, 2w, 3n, 5e" }
        xroads,weapshop      { set go "5w, 3s, 2e, s" }

        armshop,xroads      { set go "s, 3w, 3n, 5e" }
        xroads,armshop      { set go "5w, 3s, 3e, n" }

	tantres,xroads	    -
        residential,xroads  { set go "e, 3n, 5w, 3n, 5e" }
	xroads,tantres	    -
        xroads,residential  { set go "5w, 3s, 5e, 3s, w" }

        sgate,xroads            -
        southgate,xroads        { set go "4n, 5w, 3n, 5e" }
        xroads,sgate            -
        xroads,southgate        { set go "5w, 3s, 5e, 4s" }


	
        manor,xroads        { set go "s, sw, w, 8s" }
        xroads,manor        { set go "8n, e, ne, n" }

        park,xroads         { set go "out, n, 8e" }
        xroads,park         { set go "8w, s, enter park" }

	sandbox,xroads	    -
	rhot,xroads	    { set go "3e, ne, se, se, e, out, n, 8e" }	
	xroads,sandbox      -
	xroads,rhot	    { set go "8w, s, enter park, w, nw, nw, sw, 3w" }

        dump,xroads         { set go "2w, 10n" }
        xroads,dump         { set go "10s, e, enter mounds" }

        mine,xroads         { set go "2s, 3e, 16s" }
        xroads,mine         { set go "16n, 3w, 2n" }

        ravel,xroads        { set go "se, e, s, 11e" }
        xroads,ravel        { set go "11w, n, w, nw" }

	gpagob,xroads		-
	gpagoblin,xroads	-
	grandpagob,xroads	{ set go "e, out, 3s, 4e, se, e, s, 11e" }
	xroads,gpagob		-
	xroads,gpagoblin	-
	xroads,grandpagob	{ set go "11w, n, w, nw, 4w, 3n, enter, w" }

	blackorc,xroads		{ set go "w, 3u, ne, 2e, get all coins, w, enter hole, w, s, out, 3s, 4e, se, e, s, 11e" }
	xroads,blackorc		{ set go "11w, n, w, nw, 4w, 3n, enter, n, e, enter hole, e, get all coins, 2w, sw, 3d, e" }

	gobalchemist,xroads	-
	gobchem,xroads		-
	goblinalchemist,xroads	{ set go "out, s, 3e, 2s, 4e, se, e, s, 11e" }
	xroads,gobchem		-
	xroads,gobalchemist	-
	xroads,goblinalchemist	{ set go "11w, n, w, nw, 4w, 2n, 3w, n, enter" }

	gobtree,xroads	    -
	goblintree,xroads   { set go "e, s, 11e" }
	xroads,gobtree	    -
	xroads,goblintree   { set go "11w, n, w" }

        duender,xroads      -
        eldarvillage,xroads { set go "ne, n, w, 6n, 12e, 4n, 12e" }
        xroads,duender      -
        xroads,eldarvillage { set go "12w, 4s, 12w, 6s, e, s, sw" }

        xroads,listhalia    { set go "12w, 4s, 12w, 6s, e, s, sw, se, s, w, 4s, 4e, sw" }
        listhalia,xroads    { set go "ne, 4w, 4n, e, n, nw, ne, n, w, 6n, 12e, 4n, 12e" }

        xroads,drowcaves   -
        xroads,drowcaverns -
        xroads,drowcavern  -
        xroads,drow        { set go "12w, 4s, 12w, 6s, e, s, 8e, 2s, enter cave" }
        drow,xroads        -
        drowcavern,xroads  -
        drowcaverns,xroads -
        drowcaves,xroads   { set go "out, 2n, 8w, n, w, 6n, 12e, 4n, 12e" }

        xroads,monastery -
        xroads,monks     { set go "12w, 4s, 12w, 6s, e, s, 14e, enter monastery" }
        monks,xroads     -
        monastery,xroads { set go "s, 14w, n, w, 6n, 12e, 4n, 12e" }

        xroads,lichcastle -
        xroads,lich { set go "12w, 4s, 12w, 6s, e, s, 14e, s, e, s, swim e" }
        lichcastle -
        lich,xroads { set go "swim w, n, w, n, 14w, n, w, 6n, 12e, 4n, 12e" }

        xroads,lizardmensvillage -
        xroads,lizardmansvillage -
        xroads,lizardmans        -
        xroads,lizardmens        -
        xroads,lizardman         -
        xroads,lizardmen         { set go "12w, 4s, 12w, 6s, e, s, 12e, 11s, e, 4s, 2w, 6s, se" }
        lizardmen,xroads         -
        lizardman,xroads         -
        lizardmens,xroads        -
        lizardmans,xroads        -
        lizardmansvillage,xroads -
        lizardmensvillage,xroads { set go "nw, 6n, 2e, 4n, w, 11n, 12w, n, w, 6n, 12e, 4n, 12e" }

	rangers,xroads	    -
        rc,xroads           -
        rangercamp,xroads   { set go "out, n, 16w, 10s, 9e, 18s, 5w, 6s, e, s, 11e" }
	xroads,rangers	    -
        xroads,rc           -
        xroads,rangercamp   { set go "11w, n, w, 6n, 5e, 18n, 9w, 10n, 16e, s, enter camp" }

	hobbitat,rangerscamp	-
	hobbitat,rangers	-
	hobbitat,rc		-
        hob,rangerscamp    	-
        hob,rangers        	-
	hob,rc			{ set go "s, 9w, 10n, 16e, s, enter camp" }
        rangers,hob		-
        rangerscamp,hob		-
        rc,hobbitat		-
        rangers,hobbitat	-
        rangerscamp,hobbitat	-
	rc,hob			{ set go "out, n, 16w, 10s, 9e, n" }


        windmill,xroads     { set go "w, 3s, e, s, 11e" }
        xroads,windmill     { set go "11w, n, w, 3n, e" }

        xroads,orphanage { set go "11w, n, w, 3n, e, 4n, e" }
        orphanage,xroads { set go "w, 4s, w, 3s, e, s, 11e" }


        chaost,xroads		-
        chaostower,xroads	{ set go "5e, 6s, e, s, 11e" }
	xroads,chaost		-
        xroads,chaostower	{ set go "11w, n, w, 6n, 5w" }

        sati,xroads       	{ set go "3u, 5e, 6s, e, s, 11e" }
        xroads,sati      	{ set go "11w, n, w, 6n, 5w, 3d" }

        chaoszombie,xroads     	-
        chaoszomb,xroads       	{ set go "e, s, u, 5e, 6s, e, s, 11e" }
        xroads,chaoszombie	-
        xroads,chaoszomb       	{ set go "11w, n, w, 6n, 5w, d, n, w" }

        chaosphant,xroads       -
        chaosphantom,xroads     { set go "2d, s, u, 5e, 6s, e, s, 11e" }
        xroads,chaosphant       -
        xroads,chaosphantom     { set go "11w, n, w, 6n, 5w, d, n, 2u" }

        chaoshound,xroads       -
        hellhound,xroads        { set go "e, 2d, s, u, 5e, 6s, e, s, 11e" }
        xroads,chaoshound       -
        xroads,hellhound        { set go "11w, n, w, 6n, 5w, d, n, 2u, w" }

        chaoswraith,xroads      -
        chaoswrai,xroads        { set go "w, 2d, s, u, 5e, 6s, e, s, 11e" }
        xroads,chaoswraith      -
        xroads,chaoswrai        { set go "11w, n, w, 6n, 5w, d, n, 2u, e" }

        chaoswar,xroads		-
        chaoswarrior,xroads     { set go "3d, s, u, 5e, 6s, e, s, 11e" }
	xroads,chaoswar		-
        xroads,chaoswarrior     { set go "11w, n, w, 6n, 5w, d, n, 3u" }



        xroads,hauntedship  { set go "29n, 5e, enter ship" }
        hauntedship,xroads  { set go "6w, 29s" }



	clanhut,xroads	    -
        boki,xroads         -
        scyth,xroads        -
        scythe,xroads       { set go "e, 5n, 9e" }
	xroads,clanhut	    -
        xroads,scyth        -
        xroads,boki         -
        xroads,scythe       { set go "9w, 5s, walk" }

        scyshop,xroads      -
        scytheshop,xroads   { set go "n, e, s, 2e, 5n, 9e" }
        xroads,scyshop      -
        xroads,scytheshop   { set go "9w, 5s, walk, w, n, w, s" }

        scythe,scyshop      -
        scythe,scytheshop   { set go "w, n, w, s" }
        scyshop,scythe      -
        scytheshop,scythe   { set go "n, e, s, e" }

	scythe,parky	    -
        scythe,kzoaki       -
        scythe,parkraz      { set go "w, n, 2w, n" }
	parky,scythe	    -
        kzoaki,scythe       -
        parkraz,scythe      { set go "s, 2e, s, e" }

	parky,xroads	    -
        kzoaki,xroads       -
        parkraz,xroads      { set go "s, 2e, s, 2e, 5n, 9e" }
	xroads,parky	    -
        xroads,kzoaki       -
        xroads,parkraz      { set go "9w, 5s, walk, w, n, 2w, n" }



        delair,xroads       -
        dalair,xroads       { set go "4s, 16e" }
        xroads,delair       -
        xroads,dalair       { set go "16w, 4n" }

	taverna,xroads		-
	daltav,xroads		-
	daltaverna,xroads	-
	dalairtaverna,xroads	{ set go "7s, 16e" }
	xroads,taverna		-
	xroads,daltav		-
	xroads,daltaverna	-
	xroads,dalairtaverna	{ set go "16w, 7n" }



        lighthouse,xroads   { set go "6w, 11s" }
        xroads,lighthouse   { set go "11n, 6e" }

        eastroadinn,xroads  -
        eroadinn,xroads     -
        erinn,xroads        { set go "out, w, 10s" }
        xroads,eastroadinn  -
        xroads,eroadinn     -
        xroads,erinn        { set go "10n, e, enter" }

        duender,wf        -
        duender,wfinn     -
        duender,wayfarer  -
        duender,wayfarers { set go "se, s, e, s, 3e, n, 4e, s, 5e, 9s, enter" }
        wayfarer,duender  -
        wf,duender        -
        wfinn,duender     -
        wayfarers,duender { set go "out, 9n, 5w, n, 4w, s, 3w, n, w, n, nw" }

        xroads,wf        -
        xroads,wfinn     -
        xroads,wayfarer  -
        xroads,wayfarers { set go "12w, 4s, 12w, 6s, e, s, sw, se, s, e, s, 3e, n, 4e, s, 5e, 9s, enter" }
        wf,xroads        -
        wfinn,xroads     -
        wayfarer,xroads  -
        wayfarers,xroads { set go "out, 9n, 5w, n, 4w, s, 3w, n, w, n, nw, ne, n, w, 6n, 12e, 4n, 12e" }

        duender,elvendefenseforce -
        duender,edf               { set go "se, s, e, s, w, nw, n" }
        elvendefenseforce         -
        edf,duender               { set go "s, se, e, n, w, n, nw" }

        xroads,elvendefenseforce -
        xroads,edf { set go "12w, 4s, 12w, 6s, e, s, sw, se, s, e, s, w, nw, n" }
        elvendefenseforce,xroads -
        edf,xroads { set go "s, se, e, n, w, n, nw, ne, n, w, 6n, 12e, 4n, 12e" }

        xroads,sydryth -
        xroads,treevillage -
        xroads,spritevillage -
        xroads,sprites { set go "12w, 4s, 12w, 6s, e, s, 8e, 10s, nw, 2n, climb tree" }
        sprites,xroads -
        spritevillage,xroads -
        treevillage,xroads -
        sydryth,xroads { set go "climb down, 2s, se, 10n, 8w, n, w, 6n, 12e, 4n, 12e" }

        xroads,ilderia { set go "12w, 4s, 12w, 6s, e, s, sw, se, s, w, 7s, e" }
        ilderia,xroads { set go "w, 7n, e, n, nw, ne, n, w, 6n, 12e, 4n, 12e" }

        xroads,drakhiya { set go "12w, 4s, 12w, 6s, e, s, 12e, 11s, e, 5s, 4w, 7s, w, 2s, 2w, s, w" }
        drakhiya,xroads { set go "e, n, 2e, 2n, e, 7n, 4e, 5n, w, 11n, 12w, n, w, 6n, 12e, 4n, 12e" }

        xroads,diamondmonolith -
        xroads,monolith { set go "12w, 4s, 12w, 6s, e, s, 12e, 11s, e, 11s, 4w, s, w, 4s, 3e, 2s" }
        monolith,xroads { set go "2n, 3w, 4n, e, n, 4e, 11n, w, 11n, 12w, n, w, 6n, 12e, 4n, 12e" }

        xroads,nuns    -
        xroads,convent { set go "12w, 4s, 12w, 6s, e, s, 4e, n, open n, n" }
        convent,xroads -
        nuns,xroads    { set go "open s, 2s, 4w, n, w, 6n, 12e, 4n, 12e" }

        xroads,farmyard -
        xroads,farm     { set go "12w, 4s, 12w, 6s, e, s, 10e, n, enter yard" }
        farm,xroads     -
        farmyard,xroads { set go "exit, s, 10w, n, w, 6n, 12e, 4n, 12e" }

        xroads,burnhamwoods -
        xroads,burnham { set go "11w, n, w, 6n, 5e, 12n, 5w, 3n" }
        burnhamwoods,xroads -
        burnham,xroads { set go "3s, 5e, 12s, 5w, 6s, e, s, 11e" }

        xroads,arcadia { set go "11w, n, w, 6n, 5e, 12n, 5w, 2s" }
        arcadia,xroads { set go "2n, 5e, 12s, 5w, 6s, e, s, 11e" }

        xroads,fortvlaughn -
        xroads,ftvlaughn   -
        xroads,vlaughn     { set go "11w, n, w, 6n, 5e, 7n, 8w, s, w, s, w, climb slope, climb vine" }
        vlaughn,xroads     -
        ftvlaughn,xroads   -
        fortvlaughn,xroads { set go "climb vine, climb slope, e, n, e, n, 8e, 7s, 5w, 6s, e, s, 11e" }

        xroads,battlefield { set go "11w, n, w, 6n, 5e, 7n, 8w, s, w, s, 2w, n, ne" }
        battlefield,xroads { set go "sw, s, 2e, n, e, n, 8e, 7s, 5w, 6s, e, s, 11e" }

        xroads,boathouse -
        xroads,oar       -
        xroads,grapple   { set go "8s, e, ne, open n, n" }
        grapple,xroads   -
        oar,xroads       -
        boathouse,xroads { set go "open s, s, sw, w, 8n" }

        xroads,orcgardens -
        xroads,orcgarden  -
        xroads,orcgard    { set go "15w, 5s, enter garden" }
        orcgardens,xroads -
        orcgarden,xroads  - 
        orcgard,xroads    { set go "out, 5n, 15e" }

        xroads,quarry -
        xroads,quary  { set go "19n, 2w, n, 3w, s, sw" }
        quarry,xroads -
        quary,xroads  { set go "ne, n, 3e, s, 2e, 19s" }

        rc,dubo    -
        rc,gpan    -
        rc,goldpan { set go "out, e, 8n, 7e" }
        dubo,rc    -
        gpan,rc    -
        goldpan,rc { set go "7w, 8s, w, enter camp" }

        xroads,yeticave -
        xroads,yeti     { set go "31n, 9w, 10n, 6w, 14n, e, n" }
        yeticave,xroads -
        yeti,xroads     { set go "s, w, 14s, 6e, 10s, 9e, 31s" }



    }

    if {[info exists go]} {
        return $go
    }
}

#########################################
##########  Short Cut Section  ##########
# there should be plenty of documentation... hope its helpful

#### this is the /from proc with slight modifications
proc /scut input {
    global /

    if {![regexp {^\s*(\S+),?\s+(\S+)\s*$} $input => origin dest]} {
        bell
        buffer->append sys "Huh? Where did you want to go?"
        return
    }

    set go [AA-routes $origin $dest]
    if {$go != ""} {
        set /(back) "$dest $origin"
        return [/go $go]
    }

    set to_xr   [AA-routes $origin xroads]
    set from_xr [AA-routes xroads $dest]

    if {$to_xr != "" && $from_xr != ""} {
#        /go $to_xr
#        /go $from_xr
       set go [shortcut $to_xr $from_xr]
       set /(back) "$dest $origin"
       return [/go $go]
#       return
    }

    bell
    buffer->append sys \
        "Can't figure out how to get from \"$origin\" to \"$dest\" ..."
}



#### given a $to_xr and $from_xr this returns the shortcut path
#### that is only 1 example
proc shortcut {path1 path2} {

### set a flag to determine when there is no longer any possible shortcut
set complete 0

### trim and remove commas from the paths in question
regsub -all -- {,\s+} $path1 , path1
regsub -all -- {,\s+} $path2 , path2
set path1 [split [string trim $path1] ,]
set path2 [split [string trim $path2] ,]


### BEGIN While Loop - executes until all backtracking has been removed.
while {$complete != 1}  {

### set a flag to keep track of when a shortcut is found
set shorten 0


### focus on the vectors at the joining point
        set vector1 [lindex $path1 end]
        set dir1 [string trimleft [lindex $path1 end] { 0 1 2 3 4 5 6 7 8 9 }]
        set mag1 [get_magnitude [lindex $path1 end] ]
# DEBUG        puts stdout "$vector1 becomes $mag1 to the $dir1."
        set vector2 [lindex $path2 0]
        set dir2 [get_direction [lindex $path2 0] ]
        set mag2 [get_magnitude [lindex $path2 0] ]
# DEBUG        puts stdout "$vector2 becomes $mag2 to the $dir2."

### determine if the joining vectors are backtracking and if so, reduce their magnitudes accordingly
foreach { forward backward } { n s s n e w w e nw se se nw sw ne ne sw } {
# DEBUG        puts stdout "$forward, $backward pair"
    if { $dir1 == $forward && $dir2 == $backward } {
# DEBUG        puts stdout "$forward and $backward match"
        set shorten 1
        set complete 0
        if { $mag1 < $mag2 } {
                set mag2 [expr $mag2-$mag1]
                set mag1 0
        } else {
                set mag1 [expr $mag1-$mag2]
                set mag2 0
        }
# DEBUG        puts stdout "$mag1, and $mag2"
        break
    }
    set complete 1
}


### if we have reduced magnitude of the vectors, we need to replace the old vectors in path1 and path2 with the new vectors (just remove the vector if magnitude is 0) before we repead the while loop ###
if { $shorten == 1 } {

        set newpath1 ""
        set newpath2 ""

### conditionally remove vectors with magnitude 0 from original paths, or reduce the magnitude to the remaining amount after shortcutting it.
        if { $mag1 == 0 } {
                set newpath1 [string replace $path1 end-[expr [string length $vector1]-1] end]
        } else {
                set newvector "$mag1$dir1"
                set newpath1 [string replace $path1 end-[expr [string length $vector1]-1] end $newvector]
        }

        if { $mag2 == 0 } {
                set newpath2 [string replace $path2 0 [expr [string length $vector2]-1] ]
        } else {
                set newvector "$mag2$dir2"
                set newpath2 [string replace $path2 0 [expr [string length $vector2]-1] $newvector]


        }

### update the actual paths, with trimmed version of the newpaths
        set path1 [string trim $newpath1]
        set path2 [string trim $newpath2]
}

# if { $complete == 1 } { continue }


### END While Loop
}


set the_shortcut "$path1 $path2"
set the_shortcut [join $the_shortcut ,]
return $the_shortcut
}


##################
# get_magnitude - returns the magnitude of a vector passed in form Xdir where X is an integer, and dir is a compass direction
##################
proc get_magnitude {vector} {
set magnitude [string trimright $vector { , n s e w }]
if {![string is integer -strict $magnitude]} {set magnitude 1}
return $magnitude
}

##################
# get_direction - returns the direction of a vector passed in form Xdir where X is an integer, and dir is a compass direction
##################
proc get_direction {vector} {
set direction [string trimleft $vector { 0 1 2 3 4 5 6 7 8 9 }]
return $direction
}


################
# path_length -  given a comma delimitted path, calculates the distance of a given paths in terms of how many "steps" or rooms long the path is, and return the length.
################
proc path_length { path } {

        set length 0

        foreach vector $path {
                set length [expr $length+[get_magnitude $vector]]
        }

        return $length
}

############### -END OF SHORTCUT SECTION- ##############


proc /gbomb input {
    set where [lindex $input 0]

    if {[string length $where] == 0} {
        bell
        buffer->append sys "Where did you want to gbomb?"
        return
    }

    regexp {^([^+!-]+)(!?)([+-]?)$} $where => where discover resume

    set tasks [gbomb_tasks $where]   

    if {[llength $tasks] == 0} {
        bell
        buffer->append sys "Don't know how to gbomb $where"
        return
    }

    global gbomb
    global ui

    if {![info exists gbomb($where)]} {
        set gbomb($where) 0
    }

    if {$gbomb($where) >= [llength $tasks]} {
        set gbomb($where) 0
    }

    set commands {}
    if {$discover == "!"} {
        set pause " ;;;;;;;;;;;;;;;;;;;;"
        set rate 5
        set headline "/gbomb'ing $where (discovery mode)"
    } else {
        set pause " ;;;;;;"
        set rate 2
        set headline "/gbomb'ing $where (claiming mode)"
    }

    if {$resume == "-"} {
        regsub {mode} $headline "resuming mode" headline
    }

    if {$resume == "+" && $gbomb($where)} {
        set commands [join [lrange $tasks 0 [expr {$gbomb($where) - 1}]] " ;; "]
    }

    if {$resume != ""} {
        set tasks [lrange $tasks [expr {$gbomb($where) - 1}] end]
    }

    set stamina $ui(sp)
    foreach task $tasks {
        if {$stamina >= $rate} {
            append commands " ; gclaim $pause $task"
            incr gbomb($where)
            incr stamina -$rate
        } else {
            append commands " ; yawn"
            break
        }
    }
    
    buffer->append sys $headline
    set ui(entry) [string trimleft $commands " ;"]
    return [entry->process 0] 
}

proc gbomb_tasks {where} {
    switch -- $where {
        pestates {
            return [list e w e w "w ; s" w "n ; n" e n w s "n ; n" w w s s \
                "open s ; s" s s "open e ; e" n n "s ; u" "open e ; e" \
                "w ; open w ; w" "e ; open n ; n" "s ; open s ; s" \
                "n ; d ; e ; n" n "s ; s"]
        }

        canticle {
            return [list "open e ; e" "w ; n" s w n "s ; e"]
        }

        neville {
            return [list "n ; w" "e ; e ; s" "n ; e ; n" "s ; e ; n" \
                "out ; w ; w ; w ; n ; e ; e" w "w ; w" w sw "ne ; n" \
                "s ; w" "e ; s" "n ; e ; e ; s ; s"]
        }

        cyrano {
            return [list "open e ; e" n "s ; u" "d ; e ; open n ; open s" \
                n "open e ; e" "w ; s ; s" "n ; open e ; e" e enter \
                "climb mast" "d ; out ; d" n ne "sw ; s ; s" s \
                "n ; n ; u ; w ; w ; w ; w"]
        }

        mine {
            return [list n ne "sw ; nw" w n "s ; e ; n" n "open e ; e" \
                "w ; open w ; w" "e ; open n ; n" "s ; s ; s ; se ; s"]
        }

        musicman {
            return [list e n n n n "climb tree" "d ; w" w s s s \
                "enter doghouse" "e ; s" "e ; climb overhang" \
                "d ; open n ; n" n w "e ; e" "w ; n" w "e ; e" "w ; n" \
                w "e ; e ; e" w "w ; n" "s ; u" e "w ; w" "e ; s" \
                w "e ; e" "w ; s" e "w ; open w ; w" \
                "e ; n ; n ; d ; s ; s ; s ; s ; d ; s" n u]
        }

        balan {
            return [list w n "s ; s" "n ; w" n "s ; s" "n ; w" s "n ; n" \
                "s ; w" n "say visit the king ;;; n" e "w ; w" "e ; n" \
                "s ; s ; s ; w" n "s ; s" "n ; w" s "n ; n" "s ; w" n \
                n n n w u e n \
                "s ; w ; d ; e ; s ; s ; s ; s ; e ; e ; e ; e ; e ; e ; e"]
        }

        dump {
            return [list e n n e n "s ; s" s s e e n n n "s ; w" \
                "w ; s ; w ; w"]
        }

        nepeth {
            return [list s e "w ; w" "e ; n ; e" e "open s ; s" \
                "n ; open e ; e" "w ; n" w n "s ; e ; open n ; n" \
                w "e ; u" "d ; s ; e" d "u ; w ; s ; w ; w ; w" \
                w s "n ; n ; e" "w ; w" "e ; n" "u ; s ; open e ; e" \
                "w ; n ; d ; s ; s ; e ; e ; n" "open e ; e" \
                "w ; open w ; w" "e ; n" w "e ; e" "w ; n" e e u \
                "d ; w ; w ; w" w u "d ; e ; e ; n" e e n "s ; w ; w ; w" \
                w n "s ; e ; e ; open n ; n" "open w ; w" \
                "e ; open e ; e" e e n n "s ; s ; w ; w ; n" e u \
                "open e ; e" s "n ; w ; w" w "open w ; w" "open s ; s" \
                "n ; e ; e ; e ; d ; w ; open w ; w" w w \
                "search ; open w ; w" s u "d ; n ; e ; e ; e ; n ; n" \
                n n e "w ; w" s "n ; e ; n" \
                "s ; s ; s ; s ; s ; s ; s ; open s ; s ; s ; s ; s ; s"]
        }

        default { 
            return [list] 
        }
    }
}




# Make an alias
interp alias {} /upack {} /gpack

# Make an alias
interp alias {} /pack {} /ppack



#
# reload the users .mudfestrc file in case they redfined any of our procs
#

.mudfestrc 




# Running in debug mode?
if {$debug_p} { 
    catch { after cancel $autokill }
}


if {[string match tclkit* [file tail [info nameofexecutable]]]} {
    # kick off event loop
    vwait forever
}