@prog special-exit.muf
1 9999 d
1 i
: any-prop-prefix "*-special-exit" ;
: prop-prefix "*-special-exit-" ;
: tprop-prefix "*-special-exit." ;
: propname prop-prefix swap strcat ;
: tpropname tprop-prefix swap strcat ;
: startroom "startroom" ;
: n-choices "n-choices" ;
: n-alternatives "n-alternatives" ;
: loc-to-tell "loc-to-tell" ;
: now "now" ;
: trigowner "trigowner" ;
: _choice "_choice-" swap intostr strcat ;
: choicecalled "choice-called-" swap strcat ;
: alternative "alternative-" swap intostr strcat ;
: disabled "disabled-" swap intostr strcat ;
: _cost "_cost-" swap intostr strcat ;
: _move "_move-" swap intostr strcat ;
: _lock "_lock-" swap intostr strcat ;
: _fail-pfx "_fail-" tpropname ;
: _ofail-pfx "_ofail-" tpropname ;
: _premsg-pfx "_premsg-" tpropname ;
: _opremsg-pfx "_opremsg-" tpropname ;
: _postmsg-pfx "_postmsg-" tpropname swap intostr strcat "-" strcat ;
: _postmsg-force-pfx "_postmsg-force-" tpropname swap intostr strcat "-" strcat ;
: _osucc-pfx "_osucc-" tpropname swap intostr strcat "-" strcat ;
: _osucc-force-pfx "_osucc-force-" tpropname swap intostr strcat "-" strcat ;
: _odrop-pfx "_odrop-" tpropname swap intostr strcat "-" strcat ;
: _odrop-force-pfx "_odrop-force-" tpropname swap intostr strcat "-" strcat ;
: _notify "_notify-" swap intostr strcat ;
: _log "_log-" swap intostr strcat ;
: _special-exit-log-ok "_special-exit-log-ok" ;
: action "action" propname ;
: pg-confroom "_confirmer-room" ;
: confirmer-room prog pg-confroom getpropstr atoi dbref ;
: p@ propname me @ swap getpropstr ;
: pi@ p@ atoi ;
: p! propname me @ swap rot dup if 0 addprop else pop remove_prop then ;
: pi! swap intostr swap p! ;
: p= propname me @ swap rot 0 addprop ;
: px? propname me @ swap prop-exists? ;
: tp@ tpropname me @ swap getpropstr ;
: tpi@ tp@ atoi ;
: tp! tpropname me @ swap rot dup if 0 addprop else pop remove_prop then ;
: tp= tpropname me @ swap rot 0 addprop ;
: tpx? tpropname me @ swap prop-exists? ;
: rp@ propname confirmer-room swap getpropstr ;
: rpi@ rp@ atoi ;
: rp! propname confirmer-room swap rot dup if 0 addprop else pop remove_prop then ;
: rp= propname confirmer-room swap rot 0 addprop ;
: rpx? propname confirmer-room swap prop-exists? ;
: t-getpropstr me @ swap tprop-prefix swap strcat getpropstr ;
: t-prop-exists? me @ swap tprop-prefix swap strcat prop-exists? ;
: setpennies over pennies - addpennies ;
: not-an-option me @ "That is not one of your options." notify ;
: option-disabled me @ "That option is not available to you now." notify ;
: outoforder
	me @ "Sorry, this program is out of order." notify
	prog owner prog int intostr "#" swap strcat " " strcat swap strcat notify
;
: %-sub-msg
	now pi@ ctime "%t" subst me @ swap pronoun_sub
;
: say-messages ( sayfxn prefix )
	1
	begin
		over over intostr strcat me @ over prop-exists?
	while
		me @ swap getpropstr %-sub-msg 4 pick exec
		1 +
	loop
	pop pop
	pop pop
;
: tell-me me @ swap notify ;
: tell-loc loc-to-tell pi@ dbref me @ rot notify_except ;
: set-tell-loc int loc-to-tell pi! ;
: confirmer-ok?
	prog pg-confroom prop-exists? not if
		"has no " pg-confroom strcat ": property!" strcat outoforder
		0 exit
	then
	confirmer-room
	dup room? not swap #0 dbcmp or if
		"has a bad " pg-confroom strcat ": property!" strcat outoforder
		0 exit
	then
	1
;
: recover
	startroom px? if startroom pi@ dbref me @ swap moveto then
;
: clear-props
	0 me @ propfirst
	begin while
		dup any-prop-prefix dup strlen strncmp not if
			dup -4 rotate rot 1 + rot rot
		then
		pop propnext
	loop
	dup if
		1 -1 for pop me @ swap remove_prop loop
	else
		pop
	then
;
: transfer-props
	trigger @ propfirst
	begin while
		dup 4 pick dup strlen strncmp not if
			over over getpropstr over tp=
		then
		propnext
	loop
	pop
;
: transfer-all-props
	clear-props
	"_premsg-" transfer-props
	"_opremsg-" transfer-props
	"_choice-" transfer-props
	"_lock-" transfer-props
	"_cost-" transfer-props
	"_move-" transfer-props
	"_postmsg-" transfer-props
	"_osucc-" transfer-props
	"_odrop-" transfer-props
	"_fail-" transfer-props
	"_ofail-" transfer-props
	"_notify-" transfer-props
	"_log-" transfer-props
;
: get-time
	systime now pi!
;
: scan-choices
	1 begin dup _choice tpx? while 1 + loop
	1 - dup not if
		"yes;y" 1 _choice tp=
		"no;n" 2 _choice tp=
		pop 2
	then
	dup n-choices pi!
	0 n-alternatives pi!
	1 -1 for
		dup _choice tp@ ";" explode begin dup 0 > while
			1 - swap dup if
				over 3 + pick over choicecalled
				dup px? not if
					n-alternatives pi@ 1 +
					dup n-alternatives pi!
					alternative 4 pick swap p!
				then
				pi! pop
			else
				pop
			then
		loop
		pop pop
	loop
;
: disable-choice?
	dup _cost tpi@ me @ pennies > if pop 1 exit then
	dup _lock tpx? if
		dup _lock tp@ confirmer-room swap lock
		me @ confirmer-room passlock? not if pop 1 exit then
	then
	pop 0
;
: check-disable
	1 n-choices pi@ 1 for
		dup disable-choice? if
			"" swap disabled p=
		else
			pop
		then
	loop
;
: choice-disabled? disabled px? ;
: count-enabled
	0 1 n-choices pi@ 1 for choice-disabled? not if 1 + then loop
;
: find-forced-choice
	1 n-choices pi@ 1 for choice-disabled? not if exit then loop
;
: show-fail-messages
	' tell-me _fail-pfx say-messages
	me @ location set-tell-loc
	' tell-loc _ofail-pfx say-messages
;
: say-forced-messages (choice force-pfx normal-pfx tell-fn -- choice)
	4 pick 4 pick exec dup "0" strcat tpx? not if
		dup "1" strcat tpx? not if
			pop 4 pick 3 pick exec
		then
		say-messages pop pop
	else
		pop pop pop pop
	then
;
: charge-for-choice
	_cost tpi@ dup if
		dup -1 * me @ swap addpennies
		dup trigowner pi@ dbref swap addpennies
	then
	pop
;
: moveloc-for-choice
	_move dup tpx? if
		tpi@ dbref
	else
		pop #-1
	then
;
: notify-for-choice
	_notify dup tpx? if
		tp@ %-sub-msg trigowner pi@ dbref swap notify
	else
		pop
	then
;
: ok-log-object?
	dup ok? not if pop 0 exit then
	dup owner trigowner pi@ dbref dbcmp if pop 1 exit then
	_special-exit-log-ok prop-exists?
;
: make-log-entry (dbref prefix msg -- )
	3 pick 3 pick "-#" strcat over over getpropstr atoi
	( dbref prefix msg dbref #-prop n )
	1 + dup intostr 4 2 roll 3 pick 0 addprop
	( dbref prefix msg n+1 n+1str )
	4 pick "-" strcat swap strcat 5 pick swap 4 rotate 0 addprop
	( dbref prefix n+1 )
	1 + intostr "-" swap strcat strcat remove_prop
;
: log-for-choice
	_log dup tpx? if
		tp@
		dup "=" instr dup not if pop pop exit then
		1 - strcut 1 strcut swap pop
		dup ":" instr dup not if pop pop pop exit then
		1 - strcut 1 strcut swap pop
		rot atoi dbref dup ok-log-object? not if pop pop pop exit then
		rot rot %-sub-msg
		make-log-entry
	else
		pop
	then
;
: takechoice
	dup choice-disabled? if
		pop option-disabled exit
	then
	dup charge-for-choice
	' _postmsg-force-pfx ' _postmsg-pfx ' tell-me say-forced-messages
	startroom pi@ dbref set-tell-loc
	' _osucc-force-pfx ' _osucc-pfx ' tell-loc say-forced-messages
	dup moveloc-for-choice dup if
		dup set-tell-loc swap
		' _odrop-force-pfx ' _odrop-pfx ' tell-loc say-forced-messages
		me @ rot moveto
	else
		pop me @ location startroom pi@ dbref dbcmp not if
			me @ startroom pi@ dbref moveto
		then
	then
	dup notify-for-choice
	dup log-for-choice
	pop
	clear-props
;
: do-forced-choice
	find-forced-choice
	' tell-me _premsg-pfx say-messages
	me @ location set-tell-loc
	' tell-loc _opremsg-pfx say-messages
	takechoice
;
: make-choice-exits
	1 n-alternatives pi@ 1 for
		alternative p@
		dup choicecalled rpx? not if
			confirmer-room open
			dup prog addlink
			dup int intostr swap name choicecalled rp!
		else
			pop
		then
	loop
;
: do-overrider
	not-an-option
;
: do-help
	me @ "Your options are:" notify
	1 n-choices pi@ 1 for
		dup _choice tp@ swap _cost tpi@
		dup if
			" (cost: $" swap intostr strcat ")" strcat strcat
		else
			pop
		then
		"        " swap strcat me @ swap notify
	loop
;
: do-ask
	transfer-all-props
	get-time
	trigger @ owner int trigowner pi!
	loc @ int startroom pi!
	scan-choices
	check-disable
	count-enabled
	dup 0 = if pop show-fail-messages clear-props exit then
	dup 1 = if pop do-forced-choice exit then
	pop
	' tell-me _premsg-pfx say-messages
	me @ location set-tell-loc
	' tell-loc _opremsg-pfx say-messages
	make-choice-exits
	me @ confirmer-room moveto
;
: main
	( Check that the confirmer-room: property is OK. )
	confirmer-ok? not if recover clear-props exit then
	( Find out what we're doing. )
	trigger @ location confirmer-room dbcmp if
		trigger @ name
		dup choicecalled dup px? if
			swap pop pi@ takechoice
		else
			pop pop not-an-option
		then
	else
		trigger @ action getpropstr
		dup "overrider" strcmp not if pop do-overrider exit then
		dup "help" strcmp not if pop do-help exit then
		pop do-ask
	then
;
.
c
q