@prog timeout.muf
1 999 d
1 i
(
Timeout program.

Somewhat akin to Radagast's timed-death, but with different emphasis.
The prototypical situation in which we want this is a room in which a
player can do something which, say, turns a light on or off, but, if
the light remains on for [say] one minute, it turns off automatically.

This differs from timed-death in that:

- Once started, the player who started it is not special in any way;
   this is for affecting environments, not players.

- There is no "countdown".

- The timeout can be cancelled by anything that can trigger an exit.

- Each setup has only one timer.  Starting one while another is running
   will replace the first timer with the second.

- Different things happen at timer expiration; messages can be
   generated and objects can be moved, but there is no @force option.
   [Remember, the rriggering player is not special once it's started.]

Saying that a dbref "must be suitably owned" below means that it must
be owned by trigger @ owner, unless trigger @ owner is a wiz, in which
case anything goes.

This is configured with properties on a holder dbref.  The holder must
be suitably owned [or nothing happens]; it is found by getting its
number from a property _holder: on trigger @.  The only other property
which is on trigger @ instead of the holder dbref is _op:, which
controls which operation is performed.

_timeout: NNN
	The timeout, in seconds.

_expireN: ACTION
	At expiration, for N from 1 upwards until a nonexistent or
	empty property is found, ACTION is eprformed.  ACTION can be:

	emit DBREF STRING
		Send STRING to DBREF.  If DBREF is a room, STRING is
		sent to everyone in it; if a player, to that player; if
		an object, its location is used instead.  If DBREF is
		anything else, nothing happens.  DBREF must be suitably
		owned, or nothing happens.

	move DBREF1 DBREF2
		"DBREF1 DBREF2 moveto" is performed.  DBREF1 and DBREF2
		must be suitably owned, or nothing happens.

	trigger DBREF STRING
		Use trigger-exit on the dbref and string.  DBREF must
		be an exit and must be suitably owned, or nothing
		happens.

_state_*
	Properties with names beginning "_state_" are used to maintain
	state.  Creating such properties any way other than this
	program, or deleting them when present, is liable to break this
	code.

_op: OP
	[On trigger @, not on the holder dbref.]  OP specifies what
	operation is to be performed.  It can be

	start
		Start the timer.  If the timer is already running,
		restart it.

	cancel
		If the timer is not running, nothing happens.  If the
		timer is running, it is stopped, and expiration actions
		are not performed.
)
(
A running timer consists of a daemon and a property on the holder dbref
	_state_start_TIME: DAEMON
where TIME is the systime at which the daemon was started and DAEMON is
the dbref of the daemon.  Canceling a timeout consists of removing this
property; the daemon is left alone, and, if/when its timeout expires,
if the property is gone, or if the contents are wrong, it just silently
dies.  When starting a new timer, all timers already started are
canceled; this is how old properties get cleaned up after a restart.
)
$def holder-prop "_holder"
$def timeout-prop "_timeout"
$def expire-prefix "_expire"
$def state-start "_state_start_"
$def state-tag "for"
$def op-prop "_op"
$def op--start "start"
$def op--cancel "cancel"
$def action-emit "emit"
$def action-move "move"
$def action-trigger "trigger"
: to-dbref ( s -- d )
	dup "#" 1 strncmp not if 1 -1 substr then
	atoi dbref
;
: bad-owner? ( owner obj -- not-ok? )
	owner over dbcmp swap true-wizard? or not
;
: trimspaces ( s -- s )
	begin
		dup " " 1 strncmp
	not while
		1 -1 substr
	loop
	begin
		-1 strcut
	dup " " strcmp not while
		pop
	loop
	strcat
;
: spacecrack ( s -- s1 s2 )
	dup " " instr dup if
		1 - strcut 1 strcut swap pop 
	else
		pop ""
	then
;
: perform-emit ( owner trigger holder x args -- owner trigger holder x )
	spacecrack swap to-dbref
	dup ok? not if pop pop exit then
	6 pick over bad-owner? if pop pop exit then
	dup thing? if location then
	dup room? if
		#-1 rot notify_except
	else dup player? eif
		swap notify
	else
		pop pop
	then
;
: perform-move ( owner trigger holder x args -- owner trigger holder x )
	spacecrack to-dbref swap to-dbref
	( o t h x db2 db1 )
	2 copy ok? swap ok? and not if pop pop exit then
	( o t h x db2 db1 )
	6 pick dup 4 pick bad-owner? swap 3 pick bad-owner? or if pop pop exit then
	( o t h x db2 db1 )
	swap moveto
;
: perform-trigger ( owner trigger holder x args -- owner trigger holder x )
	spacecrack swap to-dbref
	dup ok? not if pop pop exit then
	6 pick over bad-owner? if pop pop exit then
	dup exit? not if pop pop exit then
	swap trigger-exit
;
: do-actions ( owner trigger holder -- )
	1
	begin
		( o t h I )
		expire-prefix over intostr strcat
		( o t h I _expireI )
		3 pick swap getpropstr
	dup while
		( o t h I action )
		trimspaces spacecrack swap
		( o t h I args verb )
		dup action-emit strcmp not if
			pop perform-emit
		else dup action-move strcmp not eif
			pop perform-move
		else dup action-trigger strcmp not eif
			pop perform-trigger
		else
			pop pop
		then
		1 +
	loop
	5 mpop
;
: start-daemon ( owner trigger holder -- )
	state-start systime intostr strcat
	fork dup not if
		( o t h _state_start_NNNNN 0 )
		pop 2 copy daemon int intostr addprop
		over timeout-prop getpropstr atoi sleep
		( o t h _state_start_NNNNN )
		over swap daemon int intostr remprop-if
		( o t h wasthere? )
		if do-actions then
		daemon kill
	then
	5 mpop
;
: do-cancel ( owner trigger holder -- )
	0 -4 rotate
	dup propfirst
	begin while
		( p1 ... pN N o t h plt pn )
		dup state-start dup strlen strncmp
		( p1 ... pN N o t h plt pn nomatch? )
		if
			pop
		else
			( p1 ... pN N o t h plt pn )
			-6 rotate 5 rotate 1 + -5 rotate
		then
		propnext
	loop
	( p1 ... pN N o t h )
	-rot pop pop
	begin
		( p1 ... pN N h )
		over 0 >
	while
		( p1 ... pN-1 pN N h )
		rot over swap remove_prop swap 1 - swap
	loop
	pop pop
;
: do-start ( owner trigger holder -- )
	3 copy do-cancel
	start-daemon
;
: main
	trigger @ dup owner swap
	( owner trigger )
	dup holder-prop getpropstr dup not if 3 mpop exit then
	to-dbref dup ok? not if 3 mpop exit then
	3 copy swap pop bad-owner? if 3 mpop exit then
	( owner trigger holder )
	over op-prop getpropstr
	( owner trigger holder op )
	dup op--start strcmp not if pop do-start exit then
	dup op--cancel strcmp not if pop do-cancel exit then
	4 mpop
;
.
c
q