@prog elevator.muf
1 999 d
1 i
(
Elevator program, interface documentation.

The elevator has four kinds of exits:
	[1]	Call the elevator
	[2]	Board the elevator
	[3]	Tell the elevator to go to a floor
	[4]	Get off the elevator

Any of them may be locked to the program; exits of types 1 and 3 may be
linked to the program instead [though that has other implications which
may not be desirable, notably that they accept arbitrary strings after
the exit name].  All exits should have an _elevator-obj: property
containing the dbref of an object that holds a bunch of properties
describing the elevator.  This can be a dbref-valued property or it can
be a string-valued property holding the dbref number.  Each exit should
also have an _elevator-action: property holding one of the four strings
"call", "enter", "floor", or "leave", according as the exit is of type
1, 2, 3, or 4 respectively.  If the program detects a botched setup, it
sends a complaint to the person who owns the trigger exit, prints a
message to the person trying to use the trigger exit, does nothing for
linked-to exits, and fails for locked exits.

Floors are known to the program by string names.  All floor references
in properties [eg, _elevator-floor: properties, see below] must take
this form.  The order of floors is determined by the _floor-order-*:
properties; see below.

Exits of type 1 must have an _elevator-floor: property that gives the
name of the floor they are supposed to call the elevator to.  [This
need not bear any relation to the room a player is in when triggering
the exit, though it normally will.]

Exits of type 2 do not need an _elevator-floor: property; the location
chain is followed from trigger @ until a room is found, whereupon its
dbref is sought among the floors.  To permit unusual setups, however,
type 2 exits may have _elevator_floor: property, in which case the
location chain is ignored and the exit is presumed to originate on that
floor.

Exits of type 3 must have an _elevator-floor: property that gives the
name of the floor the elevator is to be sent to.

Exits of type 4 may or may not have _elevator-floor: properties.  If
the exit has such a property, that exit always leads to that floor, and
the lock will fail unless the elevator is there [with the doors open].
If the exit has no such property, the exit is relinked to the
appropriate floor whenever the elevator is on a floor with the door
open.  In particular, no exit is ever relinked if all the exits of type
4 have _elevator-floor: properties; this can be used to avoid
permissions issues with the relinking.

The reason for the distinction between type 1 and type 3 exits is
planned extension to the ability to have distinct call actions for each
direction.

The object pointed to by the _elevator-obj: property should be set up
with properties describing the elevator:

	_floor-count:
		Number of floors.
	_floor-order-N: [for N from 1 through _floor-count: value]
		Name of floor N [called FN below].  These must all be
		different for the properties below to make sense.
	_floor-room-FN:
		The dbref of the room for floor FN.  Must be set for
		each floor.
	_floor-text-FN:
		A short text string describing the floor for floor FN.
		This is used in messages such as "The elevator stops at
		<floor>".  If absent, "floor FN" is used.  This should
		include an article when appropriate [eg, "parking level
		2", but "the penthouse".]
	_floor-opentime:
		Time the doors remain open at a floor, in seconds.
	_floor-uptime:
		Time between floors, going up, in seconds.
	_floor-downtime:
		Time between floors, going down, in seconds.
	_floor-opentime-FN:
		If set, overrides _floor-opentime for floor FN.
	_floor-uptime-FN:
		If set, overrides _floor-uptime for travel between
		floor FN and the next floor up.
	_floor-downtime-FN:
		If set, overrides _floor-downtime for travel between
		floor FN and the next floor down.
	_car:
		The dbref of the elevator car room itself.

Properties on the _elevator-obj: object with names beginning _el_ or
_el- should be considered private to this program; changing them
without understanding the internals of the program is a good way to
break the elevator.  The same is true of all properties on the daemon
running the elevator.  When first set up, the _elevator-obj: object
should have no _el_* or _el-* properties.

None of the dbrefs involved may be #0.  The risk that invalid strings
converting to 0 will start trashing props on the global environment is
just too high.
)

(
Internals documentation.

Internally, floors are known by small integers, 1 through MAXN, where
MAXN is the value in the _floor-count: property.

The elevator can be at any floor, or in transit between floors.
_el-loc: says which.  If the elevator is at a floor, it holds the floor
number; if the elevator is in transit, it holds two consecutive floor
numbers separated by a space, indicating the elevator is moving from
the first-numbered floor to the second-numbered floor.

When the elevator is at a floor, _el-open: is present if the doors are
open, absent if they are closed.

When the elevator is actively running, it is managed by a daemon; this
daemon's dbref is in _el-daemon:.  To permit recovery when the mud
crashes, the daemon has a property _elevator-obj: property giving the
holder dbref.  The daemon dies when the elevator is sitting idle and is
restarted as necessary.

All elevator actions are provoked by submitting requests to the daemon.
This is done by adding a property _el-req-S on the property object,
where S is any string such that the property did not formerly exist,
then adding a property _el-req [with any value], then doing a wakeup on
the property object.  The value of this property indicates the request:

	call N
		Summons to floor N by a type 1 exit.
	floor N
		Request to go to floor N by a type 3 exit.

The daemon keeps some things in props on itself, for ease of use.
These are usually anyval props with private names, names beginning with
".".  Specifically:

	.nf
		Holds the _floor-count: value [int].
	.ntoi-FN
		Holds the floor number for the floor named FN [int].
	.room-N
		Holds the _floor-room-* string for floor N [string].
	.text-N
		Holds the _floor-text-* string for floor N [string].
	.otime-N
		Holds the _floor-opentime-* value for floor N [int].
		This may come from either _floor-opentime: or
		_floor-opentime-FN:.
	.utime-N
		Holds the _floor-uptime-* value for floor N [int].
		This may come from either _floor-uptime: or
		_floor-uptime-FN:.
	.dtime-N
		Holds the _floor-downtime-* value for floor N [int].
		This may come from either _floor-downtime: or
		_floor-downtime-FN:.
	.car
		Holds the _car: value [dbref].
	.loc
		Holds the _el-loc: value if at a floor; meaningless
		when between floors.
)

( Defined interface properties [see first comment, above]. )
$def eobj-prop "_elevator-obj"
$def eact-prop "_elevator-action"
$def efloor-prop "_elevator-floor"
$def fcount-prop "_floor-count"
$def order-ppref "_floor-order-"
$def room-ppref "_floor-room-"
$def text-ppref "_floor-text-"
$def opentime-pfrag "opentime"
$def uptime-pfrag "uptime"
$def downtime-pfrag "downtime"
$def time-ppref "_floor-"
$def car-prop "_car"
( Internal properties on eobj [see second comment, above]. )
$def daemon-prop "_el-daemon"
$def req-prop "_el-req-"
$def reqf-prop "_el-req"
$def loc-prop "_el-loc"
$def open-prop "_el-open"
( Internal properties on daemon [see second comment, above]. )
$def nf-p ".nf"
$def ntoi-p ".ntoi-"
$def room-p ".room-"
$def text-p ".text-"
$def otime-p ".otime-"
$def utime-p ".utime-"
$def dtime-p ".dtime-"
$def car-p ".car"
$def loc-p ".loc"
: say me @ swap notify ;
: botched-setup (s -- )
	"Sorry, botched elevator setup." say
	trigger @
	"Botched elevator setup (" over dup owner unparse_object ") - "
	5 pick 4 "" rimplode swap owner swap notify
	0 sleep daemon kill
;
: get-dbref-prop (holder propname -- dbref)
	#-1 getpropval
	dup string? if
		dup "#" 1 strncmp not if 1 -1 substr then atoi dbref
	then
	dup ok? not if pop #-1 then
	dup #0 dbcmp if pop #-1 then (never use #0!)
;
: get-elevator-obj (dbref -- eobj)
	eobj-prop get-dbref-prop
;
: floor-name-to-number (eobj name -- eobj num)
	over fcount-prop getpropstr atoi
	dup 1 < if
		pop "missing/bad " fcount-prop " on holder"
		strcat strcat botched-setup
	then
	1 -1 for
		(eobj name n)
		order-ppref over intostr strcat 4 pick swap getpropstr
		(eobj name n)
		3 pick strcmp not if
			swap pop exit
		then
		pop
	loop
	"no floor named " swap strcat botched-setup
;
: load-floor-prop (eobj i eobj-ppref daemon-p -- eobj i)
	4 pick order-ppref 5 pick intostr strcat getpropstr
	( eobj i eobj-ppref daemon-p name )
	rot swap strcat 4 pick swap getpropstr
	( eobj i daemon-p value )
	daemon -rot swap 4 pick intostr strcat swap addprop
;
: load-time-prop (eobj i eobj-pfrag daemon-p defval -- eobj i)
	5 pick order-ppref 6 pick intostr strcat getpropstr
	( eobj i eobj-pfrag daemon-p defval floor-name )
	time-ppref 5 rotate strcat
	( eobj i daemon-p defval floor-name defpropname )
	dup rot strcat
	( eobj i daemon-p defval defpropname propname )
	6 pick swap getpropstr atoi dup 0 > if
		( eobj i daemon-p defval defpropname propval )
		-rot pop pop
	else
		( eobj i daemon-p defval defpropname propval )
		pop 5 pick swap getpropstr atoi dup 0 > if
			( eobj i daemon-p defval propval )
			swap
		then
		pop
	then
	( eobj i daemon-p value )
	daemon -rot swap 4 pick intostr strcat "any" rot setprop
;
: load-config (eobj -- eobj)
	(Loads the config, converting it into properties on the daemon.
	 This includes things like converting names to numbers in
	 properties such as _floor-room-*.)
	daemon nf-p "any"
	4 pick fcount-prop getpropstr atoi
	dup 1 < if daemon kill then
	setprop
	dup car-prop get-dbref-prop
	daemon car-p "dbref" 4 rotate setprop
	daemon nf-p 0 getpropval swap over 1 -1 for
		( eobj i )
		order-ppref over intostr strcat 3 pick swap getpropstr
		( eobj i floor-i-name )
		ntoi-p swap strcat daemon swap "any" 4 rotate setprop
	loop
	swap 1 -1 for
		( eobj i )
		room-ppref room-p load-floor-prop
		text-ppref text-p load-floor-prop
		opentime-pfrag otime-p 10 load-time-prop
		uptime-pfrag utime-p 15 load-time-prop
		downtime-pfrag dtime-p 15 load-time-prop
		pop
	loop
;
: find-requests (eobj -- eobj req1 ... reqN N)
	0
	do
		( req1 ... reqN eobj N )
		over reqf-prop prop-exists? while
		over reqf-prop remove_prop
		over propfirst do while
			( req1 ... reqN eobj N plt pn )
			dup req-prop dup strlen stringncmp if
				pop
			else
				4 pick swap
				2 copy getpropstr -rot remove_prop
				-4 rotate swap 1 + swap
			then
		propnext loop
	loop
	( req1 ... reqN eobj N )
	dup if
		swap over 2 + neg rotate
		( eobj req1 ... reqN N, reqX as strings )
		dup 1 -1 for pop
			dup 1 + rotate
			dup "call " 5 stringncmp not if
				5 -5 substr atoi swap
			else dup "floor " 6 stringncmp not eif
				6 -6 substr atoi swap
			else
				pop 1 -
			then
		loop
	then
	( eobj req1 ... reqN N, reqX as ints )
	dup if
		dup 2 + pick fcount-prop getpropstr atoi
		( eobj f1 ... fN N maxfloor )
		over 1 -1 for pop
			( eobj f1 f2 ... fN N maxfloor )
			over 2 + rotate
			( eobj f2 ... fN N maxfloor f1 )
			2 copy < over 1 < or if
				pop swap 1 - swap
			else
				-rot
			then
		loop
		pop
	then
;
: sort-uniq (i1 ... iN N -- i1 ... iM M)
	(Sorts the integers so iX < iX+1, and removes duplicates.)
	dup 2 < if exit then
	dup 2 / swap over -
	( i1 ... iA j1 ... jB B A, with A+B=N )
	over 2 + neg rotate
	( i1 ... iA A j1 ... jB B )
	sort-uniq
	( i1 ... iA A j1 ... jB B, B may have changed )
	dup 2 + pick over +
	( i1 ... iA A j1 ... jB B A+B )
	2 + over 1 + roll
	( j1 ... jB B i1 ... iA A )
	sort-uniq
	( j1 ... jB B i1 ... iA A, A may have changed )
	0 over 3 + rotate rot
	( m1 ... mN j1 ... jB i1 ... iA N B A )
	do 2 copy and while
		( m1 ... mN j1 ... jB i1 ... iA N B A )
		4 pick over 5 + pick
		( m1 ... mN j1 ... jB i1 ... iA N B A iA jB )
		2 copy = if
			( m1 ... mN j1 ... jB i1 ... iA N B A iA jB )
			pop pop 4 rotate pop 1 -
		else
			< if
				( m1 ... mN j1 ... jB i1 ... iA N B A )
				swap 1 - swap dup 4 + rotate
				( m1 ... mN j1 ... jB-1 i1 ... iA N B-1 A jB )
			else
				( m1 ... mN j1 ... jB i1 ... iA N B A )
				1 - 4 rotate
				( m1 ... mN j1 ... jB i1 ... iA-1 N B A-1 iA )
			then
			( m1 ... mN j1 ... jB i1 ... iA N B A m0 )
			4 copy pop + + 4 + neg rotate rot 1 + -rot
			( m0 m1 ... mN j1 ... jB i1 ... iA N+1 B A )
		then
	loop
	+
	( m1 ... mN k1 ... kC N C )
	2 copy + over 3 + neg rotate swap 1 + swap
	( m1 ... mN N+C k1 ... kC N+1 C )
	roll
	( k1 ... kC m1 ... mN N+C )
;
: ensure-daemon (eobj -- eobj succeeded?)
	(If the scheduling quantum is too small to complete this
	 routine, submit-request will infinite loop.  This routine
	 is small enough I consider this a "don't do that, then".)
	0 yield critical
	dup daemon-prop #-1 getpropval
	(eobj dbref)
	dup daemon? if
		dup get-elevator-obj
		(eobj daemon holder)
		dup dbref? if 3 pick dbcmp else pop 0 then if
			dup daemon dbcmp if
				(this can happen.  [a] if the critical
				 trips between the second addprop and
				 returning 1, below; [b] when we're
				 called from idle-suicide and we win
				 the race with someone else.)
				pop 1 exit
			else
				daemon kill
			then
		then
	then
	pop
	( eobj )
	daemon eobj-prop "dbref" 4 pick setprop
	dup daemon-prop "dbref" daemon setprop
	1
;
: idle-suicide (eobj -- eobj)
	(Usually does not return at all.  This requires some care to
	 avoid racing between this thread deciding to die and other
	 threads submitting requests.  We handle it by taking ourselves
	 off duty, then, if there is then a request pending, acting as
	 though we'd submitted it and trying to establish ourselves as
	 the running daemon, letting ensure-daemon handle the races.)
	dup daemon-prop daemon #-1 changeprop
	dup reqf-prop prop-exists? not if daemon kill then
	do ensure-daemon until
;
: tell-car (msg -- )
	daemon car-p #-1 getpropval #-1 rot notify_except
;
: tell-car-and-floor (msg -- )
	dup tell-car
	daemon room-p
	daemon loc-p 0 getpropval intostr
	strcat #-1 getpropval
	#-1 rot notify_except
;
: maybe-close-doors (eobj -- eobj)
	dup open-prop prop-exists? if
		dup open-prop remove_prop
		"The elevator doors close."
		tell-car-and-floor
	then
;
: maybe-open-doors (eobj -- eobj)
	dup open-prop prop-exists? not if
		dup open-prop "yes" addprop
		"The elevator doors open."
		tell-car-and-floor
	then
;
: get-time (time-p floorno -- time)
	intostr strcat daemon swap 1 getpropval
;
: delete-from-list (l1 ... lN N v -- l'1 ... l'M M)
	(if any of the l* values equal v, they're deleted)
	over 1 -1 for pop
		over 2 + rotate
		2 copy = if
			pop swap 1 - swap
		else
			-rot
		then
	loop
;
: set-loc (eobj fno -- eobj)
	2 copy intostr loc-prop swap addprop
	daemon loc-p "any" 4 rotate setprop
;
: run-daemon (ignores stack, never returns)
	depth mpop
	daemon get-elevator-obj
	( eobj )
	load-config
	dup loc-prop getpropstr atoi
	over fcount-prop getpropstr atoi
	over < over 1 < or if
		pop 1 set-loc 1
	then
	over open-prop remove_prop
	( eobj cur )
	0 1 4 rotate
	do
		( cur pend1 ... pendN N dir eobj )
		(At this point, the elevator is at floor cur.)
		find-requests
		( cur pend1 ... pendN N dir eobj req1 ... reqM M )
		dup 4 + rotate
		( cur pend1 ... pendN dir eobj req1 ... reqM M N )
		2 copy + dup 3 + -4 rotate
		( cur pend1 ... pendN dir eobj req1 ... reqM M+N+3 M N M+N )
		swap 1 + neg -rot swap 4 + neg
		( cur pend1 ... pendN dir eobj req1 ... reqM M+N+3 -[N+1] M+N -[M+4] )
		rotate
		( cur pend1 ... pendN N+M dir eobj req1 ... reqM N+M+3 -[N+1] )
		roll
		( cur dir eobj req1 ... reqM pend1 ... pendN N+M )
		sort-uniq
		( cur dir eobj req1 ... reqN N )
		dup not if
			-rot maybe-close-doors
			idle-suicide
			continue
		then
		( cur dir eobj req1 ... reqN N )
		dup 4 + pick -1 -1 4 pick 1 -1 for
			( ... reqN ... req1 N cur max<= min>= I )
			4 + pick
			( ... reqN ... req1 N cur max<= min>= reqI )
			dup 5 pick <= if
				( ... cur max<= min>= reqI )
				rot dup 0 < if 1 else 2 copy > then
				if pop dup then -rot
			then
			dup 5 pick >= if
				( ... cur max<= min>= reqI )
				swap dup 0 < if 1 else 2 copy < then
				if pop dup then swap
			then
			pop
		loop
		rot pop
		( cur dir eobj req1 ... reqN N max<= min>= )
		3 pick 5 + pick 0 < if swap then
		( cur dir eobj req1 ... reqN N nextrev nextfwd )
		dup 0 < if
			pop over 4 + rotate neg 3 pick 4 + neg rotate
		else
			swap pop
		then
		( cur dir eobj req1 ... reqN N next )
		over 5 + pick over = if
			(Already at desired next floor.)
			over 3 + pick maybe-open-doors pop
			otime-p over get-time sleep
			delete-from-list
			dup 3 + -2 roll
			continue
		then
		over 5 + -3 roll
		( req1 ... reqN N next cur dir eobj )
		maybe-close-doors
		over 0 > if "ascends" else "descends" then
		"The elevator " swap "..." 3 "" rimplode tell-car
		3 pick dup 4 pick +
		intostr swap intostr 2 " " implode
		over loc-prop rot addprop
		( req1 ... reqN N next cur dir eobj )
		over 0 > if utime-p else dtime-p then
		4 pick get-time sleep
		( req1 ... reqN N next cur dir eobj )
		over 4 rotate + 4 rotate
		( req1 ... reqN N dir eobj newcur next )
		over = if
			( req1 ... reqN N dir eobj newcur )
			daemon text-p 3 pick intostr strcat getpropstr
			"The elevator arrives at " swap "."
			3 "" rimplode tell-car
		then
		( req1 ... reqN N dir eobj newcur )
		2 copy set-loc pop
		4 pick 4 + neg rotate
		( newcur req1 ... reqN N dir eobj )
	loop
;
: submit-request (eobj request -- 1)
	fork if pop pop 1 exit then
	(eobj request)
	0 do
		(eobj request n)
		3 copy swap pop req-prop swap intostr strcat
		(eobj request n eobj _el-req-n)
		4 pick addprop-if int? if break then
		1 +
	loop
	pop pop
	(eobj)
	dup reqf-prop "" addprop
	dup wakeup
	do ensure-daemon until run-daemon
;
: get-trigger-efloor ( -- floornum)
	trigger @ efloor-prop getpropstr
	dup not if
		"missing/blank " efloor-prop " on action"
		strcat strcat botched-setup
	then
	floor-name-to-number
;
: get-trigger-efloor-default ( -- floornum)
	trigger @ efloor-prop getpropstr
	dup not if pop 0 exit then
	floor-name-to-number
;
: do-call (eobj -- boolean)
	get-trigger-efloor
	"call " swap intostr strcat
	submit-request
;
: do-enter (eobj -- boolean)
	get-trigger-efloor-default
	dup not if
		pop trigger @
		do dup room? not while location loop
		( eobj room )
		-1 3 pick fcount-prop getpropstr atoi 1 -1 for
			( eobj room -1 N )
			dup intostr order-ppref swap strcat
			( eobj room -1 N _floor-order-N )
			5 pick swap getpropstr
			( eobj room -1 N name )
			room-ppref swap strcat
			5 pick swap get-dbref-prop
			( eobj room -1 N floor )
			4 pick dbcmp if
				( eobj room -1 N )
				swap pop break
			then
			( eobj room -1 N )
			pop
		loop
		dup 0 < if
			"no/bad _elevator-floor: and dbref not found"
			botched-setup
		then
	then
	( eobj floorno )
	intostr over loc-prop getpropstr strcmp if pop 0 exit then
	open-prop prop-exists?
;
: do-floor (eobj -- boolean)
	get-trigger-efloor
	"floor " swap intostr strcat
	submit-request
;
: do-leave (eobj -- boolean)
	dup open-prop prop-exists? not if pop 0 exit then
	get-trigger-efloor-default
	dup if
		(Specifed floor.)
		( eobj floorno )
		intostr over loc-prop getpropstr strcmp not exit
	then
	(Current floor.)
	( eobj 0 )
	pop dup loc-prop getpropstr atoi
	( eobj )
	intostr order-ppref swap strcat
	( eobj _floor-order-N )
	over swap getpropstr
	( eobj name )
	room-ppref swap strcat over swap get-dbref-prop
	( eobj floor )
	trigger @ unlink
	trigger @ swap addlink
	pop 1
;
: main
	trigger @
	dup get-elevator-obj
	dup not if
		pop pop "missing/bad " eobj-prop strcat botched-setup
	then
	( eobj )
	trigger @ eact-prop getpropstr
	dup "call" strcmp not if
		pop do-call exit
	then
	dup "enter" strcmp not if
		pop do-enter exit
	then
	dup "floor" strcmp not if
		pop do-floor exit
	then
	dup "leave" strcmp not if
		pop do-leave exit
	then
	pop "bad " eact-prop strcat botched-setup
;
.
c
q