@prog pick-exit-clone.muf
1 999 d
1 i
( Random exit chooser program.  Picks one of a set of exits randomly,
  possibly with unequal probability.

  Usage: lock an exit to this program.  Then put properties _rexit1,
  _rexit2, etc, on the exit; each one should have as its value the
  dbref number of an exit that may be chosen.  When someone takes the
  exit, this program will pick one of the other exits and reset the
  strings and links of the exit being taken to match those of the exit
  chosen randomly.  To change the relative probabilities, append a
  slash and a number to a property value.  The number after the slash
  is a probability.  Exits with no probability given are treated as
  though 100 were given for them; the probabilities are all taken
  relative to the sum of all probability values.

  Exits listed as having probability less than 1 are ignored, as are
  those which don't specify an exit dbref.  If the trigger exit is not
  owned by a wizard, exits whose owner differs from those of the
  trigger are also ignored.  If all exits are ignored, the lock fails.

  The attributes of the chosen exit that are copied are: @succ, @osucc,
  @drop, @odrop, all links.  In particular, the @fail, @ofail, and lock
  are not copied.  The owner of the trigger exit is preserved.
)
: pfx "_rexit" ;
: get-prob (n -- prob)
	(this word returns 0 for bad properties and 100 for missing ones.)
	intostr pfx swap strcat trigger @ swap getpropstr
	dup "/" instr dup if
		strcut atoi dup 0 < if pop 0 then
		dup if
			swap atoi dbref dup exit? if
				owner trigger @ owner dbcmp not if pop 0 then
			else
				pop pop 0
			then
		else
			swap pop
		then
	else
		pop pop 100
	then
;
: copy-things
	dup succ trigger @ swap setsucc
	dup osucc trigger @ swap setosucc
	dup drop trigger @ swap setdrop
	dup odrop trigger @ swap setodrop
	trigger @ owner swap
	trigger @ unlink
	getlinks begin dup 0 > while 1 - swap trigger @ swap addlink loop
	pop
	trigger @ swap chown
;
: main
	-1 0
	1
	begin
		( choice probsum n )
		pfx over intostr strcat trigger @ swap prop-exists?
	while
		dup get-prob 3 pick +
		( choice probsum n newsum )
		dup if
			random over %
			( choice probsum n newsum rv )
			4 pick >= if over 4 put then
		then
		rot pop swap
		1 +
	loop
	( choice probsum n )
	pop pop dup 0 < if pop 0 exit then
	intostr pfx swap strcat trigger @ swap getpropstr
	atoi dbref copy-things
	1
;
.
c
q