@prog maze.muf
1 9999 d
1 i
: say me @ swap notify ;
: proppfx ".maze-" ;
: vi! (v s -- ) proppfx swap strcat me @ swap rot intostr addprop ;
: vi@ (s -- v) proppfx swap strcat me @ swap getpropstr atoi ;
: vs! (v s -- ) proppfx swap strcat me @ swap rot addprop ;
: vs@ (s -- v) proppfx swap strcat me @ swap getpropstr ;
: vrm (s -- ) proppfx swap strcat me @ swap remove_prop ;
: split (s delim -- pre post)
	over over instr 1 - rot swap strcut rot strlen strcut swap pop
;
: n-copies (s n)
	over 1 begin dup 4 pick < while swap dup strcat swap dup + loop
	pop rot strlen rot * strcut pop
;
: pick-random-cell ( list -- newlist cell 1 / 0 )
	"/" split swap atoi
	dup not if pop pop 0 exit then
	dup 1 - intostr "/" strcat rot
	begin
		"/" split random 5 pick % if
			rot rot strcat "/" strcat rot 1 - swap rot
		else
			rot swap strcat rot pop swap atoi 1 exit
		then
	loop
;
: cell-to-rc "c" vi@ over over / rot rot % ;
: rc-to-cell swap "c" vi@ * + ;
: map-neighbors (stuff cell fn -- stuff)
	(fn is <stuff x1 ... xN N neighborcell -- otherstuff x1 ... xN N>)
	swap cell-to-rc
	over 0 > if over 1 - over rc-to-cell 3 swap 5 pick exec pop then
	dup 0 > if over over 1 - rc-to-cell 3 swap 5 pick exec pop then
	over "r" vi@ 1 - < if over 1 + over rc-to-cell 3 swap 5 pick exec pop then
	dup "c" vi@ 1 - < if over over 1 + rc-to-cell 3 swap 5 pick exec pop then
	pop pop pop
;
: save-unseen-neighbor (M x1 ... xN N ngh -- { M / ngh M+1 } x1 ... xN N)
	"seen" vs@ over strcut 1 strcut pop swap pop atoi if pop exit then
	over 3 + -1 * rotate dup 2 + rotate 1 + over 2 + -1 * rotate
;
: see-cell (cell -- )
	"seen" vs@
	swap strcut 1 strcut swap pop "1" swap strcat strcat
	"seen" vs!
;
: add-cell-to-list ( list cell -- newlist )
	intostr strcat "/" strcat dup "/" instr 1 - strcut
	swap atoi 1 + intostr swap strcat
;
: open-wall (cell dir -- )
	dup vs@ rot strcut 1 strcut swap pop "1" swap strcat strcat swap vs!
;
: open-between (cell1 cell2 -- )
	over 1 + over = if "lf" open-wall pop exit then
	over 1 - over = if pop "lf" open-wall exit then
	over over < if "up" open-wall pop exit then
	pop "up" open-wall
;
: show-help
	"help" say
	"    show this message" say
	"show <r>,<c>" say
	"    construct and show maze of <r> rows, <c> cols" say
	"walk <how> <r>,<c>" say
	"    construct maze of <r> rows, <c> cols, and walk through it." say
	"    <how> can be:" say
	"        dirs - show maze cells in abbreviated room format," say
	"                showing n/s/e/w exit possibilities." say
	"        draw - show maze cells in small graphics format" say
	"        3d   - show an ascii-graphics 3-D perspective view" say
;
: set-size
	"," explode
	dup 2 = not if
		1 -1 for pop pop loop
		"Size must be given as <rows>,<cols>" say
		1 exit
	then
	pop atoi "r" vi! atoi "c" vi!
	0
;
: make-maze
	"Making " "r" vi@ intostr strcat "x" strcat "c" vi@ intostr strcat
	" maze (total cell count: " strcat "r" vi@ "c" vi@ * intostr strcat
	")." strcat say
	systime "t0" vi!
	"r" vi@ "c" vi@ * "0" swap n-copies
	dup "up" vs!
	dup "lf" vs!
	dup "seen" vs!
	strlen random swap % dup see-cell "0/" swap add-cell-to-list "list" vs!
	begin
		"list" vs@ pick-random-cell
	while
		0 over ' save-unseen-neighbor map-neighbors
		( newlist cell ngh1 ... nghN N )
		dup if
			random over % 2 + pick over 2 + -1 * rotate
			dup 1 -1 for pop swap pop loop
			( newlist cell ngh N )
			over see-cell
			4 rotate swap 1 > if pop "list" vs@ then
			over add-cell-to-list "list" vs!
			open-between
		else
			pop pop "list" vs!
		then
	loop
	systime "t1" vi!
;
: setup-rt-and-dn
	"up" vs@ "c" vi@ strcut swap strcat "dn" vs!
	"lf" vs@ 1 strcut swap strcat "rt" vs!
;
: open-exit
	"c" vi@ "r" vi@ over + random swap % over over > if
		random 2 % if swap pop "up" else swap "r" vi@ 1 - * + "dn" then
		open-wall
	else
		random 2 % if * "lf" else over * + 1 - "rt" then open-wall
	then
;
: announce-time
	"Time taken: " "t1" vi@ "t0" vi@ - dup intostr swap
	1 = if " second." else " seconds." then strcat strcat say
;
: print-maze
	"c" vi@ 1 -
	0 "r" vi@ 1 - 1 for
		( maxcol r )
		""
		0 4 pick 1 for
			( maxcol r s c )
			3 pick swap rc-to-cell
			( maxcol r s cell )
			"up" vs@ swap strcut 1 strcut pop swap pop atoi
			if "+   " else "+---" then strcat
		loop
		"+" strcat say
		""
		0 4 pick 1 for
			( maxcol r s c )
			3 pick swap rc-to-cell
			( maxcol r s cell )
			"lf" vs@ swap strcut 1 strcut pop swap pop atoi
			if "    " else "|   " then strcat
		loop
		"|" strcat say
		pop
	loop
	"" swap 0 -1 for pop "+---" strcat loop "+" strcat say
;
: place-walker
	random "c" vi@ % "x" vi!
	random "r" vi@ % "y" vi!
;
: in-maze?
	"x" vi@ dup 0 < if pop 0 exit then
	"c" vi@ < not if 0 exit then
	"y" vi@ dup 0 < if pop 0 exit then
	"r" vi@ < not if 0 exit then
	1
;
: is-wall-open? vs@ swap strcut 1 strcut pop atoi swap pop ;
: add-show-dir (s x dir -- s' x) rot dup if ", " strcat then swap strcat swap ;
: show-cell
	"You can move: " ""
	"y" vi@ "x" vi@ rc-to-cell
	dup "up" is-wall-open? if "north" add-show-dir then
	dup "dn" is-wall-open? if "south" add-show-dir then
	dup "rt" is-wall-open? if "east" add-show-dir then
	dup "lf" is-wall-open? if "west" add-show-dir then
	pop strcat "  [q to quit, %cmd to execute a muck command]" strcat say
;
: do-move over vi@ + swap vi! ;
: maybe-move
	"y" vi@ "x" vi@ rc-to-cell over is-wall-open? not if
		"There's a wall in the way!" say exit
	then
	dup "up" strcmp not if pop "y" -1 do-move exit then
	dup "dn" strcmp not if pop "y"  1 do-move exit then
	dup "lf" strcmp not if pop "x" -1 do-move exit then
	dup "rt" strcmp not if pop "x"  1 do-move exit then
	"Impossibility in maybe-move" 99 pstack 0 sleep daemon kill
;
: take-step
	read
	dup "%" 1 strncmp not if
		1 strcut swap pop
prog "d" set
		me @ swap force	nop
		"(continue)" say
prog "!d" set
		exit
	then
	1 strcut pop
	dup "q" stringcmp not if pop -1 "x" vi@ -1 "y" vi@ exit then
	dup "n" stringcmp not if pop "up" maybe-move exit then
	dup "s" stringcmp not if pop "dn" maybe-move exit then
	dup "e" stringcmp not if pop "rt" maybe-move exit then
	dup "w" stringcmp not if pop "lf" maybe-move exit then
	pop "Unknown direction." say
;
: clear-vars
	me @ name "Mouse" strcmp not if exit then
	"r" vrm "c" vrm
	"up" vrm "lf" vrm "dn" vrm "rt" vrm
	"seen" vrm "list" vrm
	"t0" vrm "t1" vrm
	"x" vrm "y" vrm
;
: show-maze
	set-size if exit then
	make-maze announce-time print-maze
	clear-vars
;
: walk-dirs
	set-size if exit then
	make-maze announce-time setup-rt-and-dn open-exit
	place-walker begin in-maze? while show-cell take-step loop
	clear-vars
;
: walk-draw
	nop
;
: walk-3d
	nop
;
: main
	dup not if pop show-help exit then
	dup "help" strcmp not if pop show-help exit then
	dup "show " 5 strncmp not if 5 strcut swap pop show-maze exit then
	dup "walk dirs " 10 strncmp not if 10 strcut swap pop walk-dirs exit then
	dup "walk draw " 10 strncmp not if 10 strcut swap pop walk-draw exit then
	dup "walk 3d " 8 strncmp not if 8 strcut swap pop walk-3d exit then
	pop "Unknown command - try `help'" say
;
.
c
q