@prog morph.muf
1 9999 d
1 i
(
Morph commands:

@desc:string
	Sets "me @"'s desc to the string.
prop:propname
	Removes the prop from me @.
prop:propname:value
	Sets the prop on me @ to the given value.
succ:string
	Prints the string to me @.
osucc:string
	Prints the string to everyone but me @ in me @ location.
if:expression:command
	Executes the command if the expression returns true.  The
	expression is made up of parentheses, &, |, ! for Boolean
	combination, and primitives are strings which return true
	if they match the current state.
use:tag
	Unconditionally transfers to line 1 of tag; also does the
	equivalent of "newstate:tag".
goto:tag
	Unconditionally transfers to line 1 of tag, like use:, but
	does not do the implicit newstate.
call:tag
	Transfers to line 1 of tag, but when that finishes, resumes here.
newstate:tag
	Sets the to-be-installed state.
return
	Exits from the current tag, either returning to the one that
	called it or exiting.
error
error:string
	Exits immediately, without installing the to-be-installed new
	state tag.  If the string is given and non-empty, it is printed
	to me @.

The argument is taken as a tag, and code is executed beginning at line 1
of that tag.

Tags beginning with a . character have the special property that they are
not listed by the "list" command.
)
(
During execution, the stack is
	pfxN lineN ... pfx1 line1 N curpfx curline newstate
where the pfxX lineX pairs are the return stack for "call", with
the most recent call's return at the top, pfx1 line1.  What's on
the stack are actually property prefixes, not tags, for the *pfx
stack elements.  This piece of the stack is "std" below.
)
forward one-command
forward eval-|-expr
: say me @ swap notify ;
$def stateprop "_morph/state"
: make-prefix "_morph/" swap "-" 3 "" rimplode ;
: cmd-list
	me @ propfirst begin while
		dup "_morph/" 7 stringncmp if
			pop
		else dup strlen 2 - strcut "-1" strcmp eif
			pop
		else dup strlen 7 <= eif
			pop
		else
			7 strcut dup "." 1 strncmp if say else pop then pop
		then
		propnext
	loop
;
: pfx-exists?
	"1" strcat me @ swap prop-exists?
;
: colonsplit
	dup ":" instr dup if
		1 - strcut 1 strcut swap pop 1
	then
;
: colonsplit-empty
	dup ":" instr dup if
		1 - strcut 1 strcut swap pop swap
	else
		pop "" swap
	then
;
: expr-op-chr? "()&|!" swap instr ;
: non-op-token
	begin
		over not if exit then
		swap 1 strcut -rot
		dup expr-op-chr? if rot strcat swap exit then
		strcat
	loop
;
: eval-single
	dup not if "Unexpected end of expression" say 0 exit then
	1 strcut swap
	dup "!" strcmp not if
		pop eval-single not exit
	then
	dup "(" strcmp not if
		pop eval-|-expr over ")" 1 strncmp if
			pop pop "" 0 "Unclosed (" say exit
		then
		swap 1 -1 substr swap exit
	then
	dup expr-op-chr? if
		"Unexpected " swap strcat say
		pop "" 0 exit
	then
	non-op-token
	me @ stateprop getpropstr strcmp not
;
: eval-&-expr
	eval-single
	begin over "&" 1 strncmp not while
		swap 1 -1 substr eval-single rot &
	loop
;
: eval-|-expr
	eval-&-expr
	begin over "|" 1 strncmp not while
		swap 1 -1 substr eval-&-expr rot |
	loop
;
: eval-expression (s -- 0/1)
	eval-|-expr
	over if "Junk after expression: " rot strcat say else swap pop then
;
: do-@desc
	me @ swap setdesc
;
: do-prop
	dup ":" instr dup if
		1 - strcut 1 strcut swap pop me @ -rot addprop
	else
		pop me @ swap remove_prop
	then
;
: do-succ
	say
;
: do-osucc
	me @ location me @ rot over name " " swap strcat notify_except
;
: do-use
	-4 rotate pop pop pop dup make-prefix swap 0 swap
;
: do-goto
	make-prefix -4 rotate -rot pop pop 0 swap
;
: do-call
	5 rotate 1 + -3 rotate make-prefix 0 rot
;
: do-newstate
	swap pop
;
: do-if
	colonsplit-empty
	eval-expression if
		one-command
	else
		pop 0
	then
;
: do-return
	pop
	4 rotate dup 0 > if
		1 - -6 rotate -rot pop pop 0
	else
		-4 rotate 0 1
	then
;
: do-error
	dup if say else pop then
;
: one-command (std cmd -- std 0 / std errored? 1)
	colonsplit-empty
	dup "@desc" strcmp not if pop do-@desc 0 exit then
	dup "prop" strcmp not if pop do-prop 0 exit then
	dup "succ" strcmp not if pop do-succ 0 exit then
	dup "osucc" strcmp not if pop do-osucc 0 exit then
	dup "use" strcmp not if pop do-use 0 exit then
	dup "goto" strcmp not if pop do-goto 0 exit then
	dup "call" strcmp not if pop do-call 0 exit then
	dup "newstate" strcmp not if pop do-newstate 0 exit then
	(the rest are special cases)
	dup "if" strcmp not if pop do-if exit then
	dup "return" strcmp not if pop do-return exit then
	dup "error" strcmp not if pop do-error 1 1 exit then
	"Invalid morph command (unrecognized): "
	swap rot ":" swap 4 "" rimplode say 1 1
;
: command-loop (std -- std errored?)
	begin
		swap 1 + swap
		3 pick 3 pick intostr strcat me @ swap
		over over prop-exists? if getpropstr else pop pop "return" then
		one-command
	until
;
: main
	dup "list" strcmp not if pop cmd-list exit then
	0 swap dup make-prefix swap 0 swap
	( std )
	3 pick pfx-exists? not if
		": no such morph command set up" strcat say
		pop pop pop exit
	then
	command-loop
	if pop else me @ stateprop rot addprop then
	pop pop 2 * mpop
;
.
c
q