@prog boots.muf
1 999 d
1 i
(
Seven-league boots.  Assuming an exit "boots" linked to this program,
"boots 6 n" will move you six rooms north.  How it does this depends on
the _method: property attached to the exit:
	_method: force
		Moves you by FORCEing you to execute "n" six times.
	_method: teleport
		Moves you by tracing exits and MOVETOing you.
[If no _method: property is found, a complaint is printed and nothing
is done.]  If _method:force is used, this can be used to repeat
non-movement commands as well.  If _method:teleport is used,
ambiguities [the presence of multiple exits with the given name from a
given room] will produce a complaint and no motion, as will exits
linked to non-rooms or a failure to find a matching exit.  When
_method:teleport is used, a message is emitted to the departure room
appropriate to the @osucc of the first exit, and to the arrival room
appropriate to the @odrop of the last exit.  Also for _method:teleport,
the action can be given as multiple names separated by semicolons; when
this is done, the program searches for each in turn, left to right,
stopping as soon as a name is found for which at least one exit exists.
This search is repeated for each room stepped through.

Inappropriate usage [missing or invalid number, for example] also
produces complaints.

You can do multiple motions in a single command by repeating the
<number> <exitname> pairs.  As a special case, if the first <number> is
an asterisk, the rest of the arguments are taken as exit names, with a
number of 1 assumed.
)
( Note: code assumes both trailtrail and maxtrail-trailtrail are >=1 )
$def maxtrail 6 (max # of rooms listed in printed path)
$def trailtrail 3 (number of them that get printed after the ellipsis)
: xps me @ "@boots-debug" prop-exists? if pstack else pop then ;
: privileged? me @ royalty? ;
: say me @ swap notify ;
: exit-name trigger @ name dup ";" instr dup if 1 - strcut then pop ;
: usage
	exit-name
	"Usage: " over strcat " <n> <cmd> [<n> <cmd> ...]" strcat say
	"       " over strcat " * <cmd> [<cmd> ...]" strcat say
;
: strip-empty-explosions ( sN ... s1 N -- sM ... s1 M )
	dup 1 -1 for dup 2 + pick if pop else 1 + rotate pop 1 - then loop
;
: split-argument (s -- sN nN ... s1 n1 N 0 / 1)
	" " explode
	strip-empty-explosions
	dup 1 <= if mpop usage 1 exit then
	over "*" strcmp not if
		swap pop 1 -
		( sN ... s1 N )
		1 over 1 for
			( sN ... si si-1 1 ... s1 1 N i )
			1 swap -2 * rotate
		loop
		0 exit
	then
	dup 2 % if mpop usage 1 exit then
	2 / dup 1 -1 for
		( sN nN ... si+1 ni+1 si sni si-1 sni-1 ... s1 sn1 N i )
		2 * dup 1 + rotate atoi dup 0 <= if
			pop swap 2 * mpop usage 1 exit
		then
		swap -1 * rotate
	loop
	0
;
: move-force
	split-argument if exit then
	begin dup 0 > while
		1 - rot rot 1 -1 for pop me @ over force loop pop
	loop pop
;
: exit-namecmp-e strcmp ;
: exit-namecmp-!e stringcmp ;
: find-exit-named (room string -- exit 1 0 [ok] / 0 0 [none] / 1 [err])
	#-1 rot exits
	begin dup while
		( string found exit )
		dup "e" flag? if ' exit-namecmp-e else ' exit-namecmp-!e then
		over "f" flag? if
			over name 1
		else
			over name ";" explode
		then
		( string found exit cmpfn nN ... n1 N )
		begin 99 xps dup 0 > while
			1 - swap
			over 6 + pick 3 pick 4 + pick exec
			not if
				mpop pop
				dup getlink room? not if
					0 0 break
				then
				dup locked? if
					privileged? not if
						me @ over passlock? not if
							0 0 break
						then
					then
				then
				swap dup if
					"Ambiguous exits from " over location
					me @ unparse_object strcat
					": " strcat swap me @ unparse_object
					strcat " and " strcat
					swap me @ unparse_object strcat
					swap pop say 1 exit
				then
				pop dup 0 0
			then
		loop
		pop pop next
	loop
	pop dup if swap pop 1 0 exit then
	pop pop 0 0
;
: find-exit (room string -- exit 0 / 1)
	over
	begin dup while
		( roomarg stringarg room )
		over ";" explode begin dup 0 > while
			1 - swap
			( roomarg stringarg room sN ... s1 N s )
			over 3 + pick swap find-exit-named if
				( roomarg stringarg room sN ... s1 N )
				3 + mpop 1 exit
			then
			if
				( roomarg stringarg room sN ... s1 N exit )
				over 5 + -1 * rotate 3 + mpop 0 exit
			then
		loop
		pop location
	loop
	pop pop me @ unparse_object
	privileged? if
		"Can't find an exit by that name from "
	else
		"Can't find an unlocked exit by that name from "
	then swap "!" strcat strcat say 1
;
: update-loclist ( l1 ... lN N x1 ... xM M loc -- l1 ... lN' N' x1 ... xM )
	over 3 + pick maxtrail <= if
		( l1 ... lN N x1 ... xM M loc )
		over 4 + dup rotate 1 + over neg rotate
		( l1 ... lN N+1 x1 ... xM M loc M+4 )
		1 - neg rotate pop
		( l1 ... lN loc N+1 x1 ... xM )
	else
		int
		( l1 ... lN-trailtrail-1 ... lN N x1 ... xM M loc )
		over 3 + dup trailtrail 2 + + rotate pop
		( l1 ... ... lN N x1 ... xM M loc M+3 )
		neg rotate pop
		( l1 ... ... lN loc N x1 ... xM )
	then
;
: namesay me @ unparse_object say ;
: move-teleport
	0 swap split-argument if exit then
	( 0 s1 n1 ... sN nN N )
	me @ location 4 pick find-exit if 2 * mpop pop exit then
	over 2 * 2 + 1 roll
	( 0 firstexit s1 n1 ... sN nN N )
	0 me @ location
	( 0 firstexit s1 n1 ... sN nN N 0 loc )
	begin 3 pick 0 > while
		( l1 ... lM M firstexit s1 n1 ... sN-1 nN-1 sN nN N lastexit loc )
		rot 1 - rot 5 rotate 4 rotate 5 rotate
		( l1 ... lM M firstexit s1 n1 ... sN-1 nN-1 N-1 lastexit sN loc nN )
		1 -1 for pop
			( ... lastexit str curloc )
			dup 3 pick find-exit if
				pop pop pop 2 * mpop pop mpop exit
			then
			( ... lastexit str curloc exit )
			4 rotate pop dup -4 rotate
			( ... lastexit str curloc exit )
			swap pop dup getlink swap pop
			( ... lastexit str curloc )
			4 pick 2 * 5 + over update-loclist
		loop
		swap pop
	loop
	( l1 ... lM M firstexit 0 lastexit loc )
	rot pop
	over int? if pop pop pop mpop "No motion!" say exit then
	( l1 ... lM M firstexit lastexit targetloc )
	4 pick 4 + 3 roll
	( firstexit lastexit targetloc l1 ... lM M )
	over int? if rot dup int? not if int then -rot then
	swap pop 1 - dup if
		over int? if
			pop
			maxtrail trailtrail 1 + -1 for
				rotate namesay
			loop
			"..." say
			trailtrail 1 -1 for
				rotate dup int? if dbref then namesay
			loop
		else
			1 -1 for
				rotate namesay
			loop
		then
	else
		pop
	then
	me @ "d" flag? if
		swap pop swap pop me @ swap moveto
	else
		me @ location me @ dup 6 rotate
		osucc dup not if pop "has left." then
		pronoun_sub me @ name swap " " swap strcat strcat
		notify_except
		dup me @ dup 5 rotate
		odrop dup not if pop "has arrived." then
		pronoun_sub me @ name swap " " swap strcat strcat
		notify_except
		me @ dup "d" set dup 3 rotate moveto "!d" set
	then
;
: main
	"me" match me ! trig trigger !
	trigger @ "_method" getpropstr
	dup "force" strcmp not if pop move-force exit then
	dup "teleport" strcmp not if pop move-teleport exit then
	pop pop
	trigger @ "_method" prop-exists? if "Inappropriate" else "No" then
	" _method: property on trigger" strcat say
;
.
c
q